Solved

Copying Across Data via VBA

Posted on 2013-01-13
21
294 Views
Last Modified: 2013-01-14
Hello,

I have the code below which I need a little bit of help with.

I am currently matching a value on the Data sheet and if this is equals IMMS then it will copy certain cells over to the Actuals sheet.

You will see that I have two blanks in the array as I need to do something with the data when it is copied across and I am not sure how :

        Array(Cells(i, 5), _
            "", _
            Cells(i, 6), _
            Cells(i, 3), _
            Cells(i, 7), _
            "", _
            Cells(i, 2), _
            Cells(i, 1))

With the first blank I would like to do the following when it is copied across to the actuals sheet.

I have another worksheet with called 'Names' on that worksheet I have a list of names in column A and a job title in Column B for that resource.

When I copy across the data I would like to put the job title for that resource - the name of which is held in Cells(i, 6). Essentially the code would have to take the name from   Cells(i, 6) match it to the name on the 'Names' worksheet and then copy the job title where it matched the name onto the actual worksheet - if that makes sense :)

I have attached a working current worksheet of how it works with the names worksheet on also.

I hope that I have explained this ok, but if you have any questions please let me know.

Many thanks,

GISVPN.










Sub OK_y_run()
Dim xlast_Row As Long
Dim xNew_Row As Long
Dim i As Long

Sheets("Data").Activate
xlast_Row = Range("A1").SpecialCells(xlLastCell).Row
If xlast_Row < 2 Then
    MsgBox ("No data in PAS Spreadsheet - run cancelled.")
    Exit Sub
End If

    
    Sheets("Actual").Activate
    Range("A4:H50000").Select
    Selection.ClearContents
    Sheets("Data").Activate

If Sheets("Actual").UsedRange.Rows.Count < 0 Then MsgBox ("Error") ' Force Excel to recalculate the last row.
xNew_Row = Sheets("Actual").Range("A:A").SpecialCells(xlLastCell).Row

For i = 3 To xlast_Row
    If Cells(i, 8) = "IMMS" Then
    xNew_Row = xNew_Row + 1
        Sheets("Actual").Range("A" & xNew_Row & ":H" & xNew_Row) = _
            Array(Cells(i, 5), _
            "", _
            Cells(i, 6), _
            Cells(i, 3), _
            Cells(i, 7), _
            "", _
            Cells(i, 2), _
            Cells(i, 1))
    End If
Next

Open in new window

Example-1---Copying-Cells.xlsm
0
Comment
Question by:gisvpn
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 10
  • 7
  • 4
21 Comments
 
LVL 24

Expert Comment

by:Steve
ID: 38773549
To start off... is there a lot of data (rows) to process each time?
If there is more than a thousand, it would be far faster to work with an array of the data.
If there is only ever a few hundred the time diference is likely negligible.

As for finding the names... use a dictionary item filled at the start... see here for detail.

I will look at writing the code for this once we know how many data lines there are.
0
 

Author Comment

by:gisvpn
ID: 38773573
Hi ;)

In the Data worksheet there are about 1000-7000 lines to go through. On the Names worksheet there will be 30 lines of names max.

I will look at the article you posted too.
0
 
LVL 26

Assisted Solution

by:redmondb
redmondb earned 250 total points
ID: 38773574
Hi, gisvpn.

Please see attached.

Regards,
Brian.Example-1---Copying-Cells-V2.xlsm
0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:gisvpn
ID: 38773578
Would you recommend putting the resource names along with the job title into a dictionary and for each lines look up and match the resource name from the dictionary and then get the job title from there in this method?
0
 
LVL 24

Accepted Solution

by:
Steve earned 250 total points
ID: 38773620
Here is my response for consideration...

Note the lack of "selects" in there to speed it all up.
It could still be faster (fill an array with the results then paste that array), but this should be OK.

If you are going to fill in the second blank with resource than it may be best to fill the name table with this too.
Example-1---Copying-Cells.xlsm
0
 

Author Comment

by:gisvpn
ID: 38773632
Thank you for the two examples, it is useful to know both ;)
0
 
LVL 24

Expert Comment

by:Steve
ID: 38773635
OK just tested the two methods...
Over the small data set in your example workbook...
Not using an array (such as your first code) takes .07812s
The array method is .01562s so 80% faster.
Please bear this in mind as off sheet handling is a must for larger data sets.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38773651
Gisvpn, please look at making a change to the method of choosing the last data row...

SpecialCells(xlLastCell) can often be wrong after using the .ClearContents as it still sees the cleared cells as being used.
xNew_Row = Sheets("Actual").Range("A:A").SpecialCells(xlLastCell).Row

Open in new window


Please try using the following which is more stable...
With Sheets("Actual")
    xNew_Row = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Open in new window

0
 
LVL 26

Expert Comment

by:redmondb
ID: 38773668
Thanks, Gisvpn.

I had seen the issue about last cell, so I cheated and output to the row following the header!

The_Barman
A bit Big-Endian v. Little-Endian, but...
The danger with the xlUp approach is that blank cells in the column can have a disastrous effect (not, perhaps, relevant here). At worst, the xlLastCell approach will cause blank rows, but even this can be avoided by preceding it by a line such as...
If ActiveSheet.UsedRange.Rows.Count < 0 Then Debug.Print "!"

Regards,
Brian,
0
 
LVL 24

Expert Comment

by:Steve
ID: 38773684
Indeed Brian, but it is mostly after the clearcontents that lastcell goes awry, hence suggesting the change.

I tend to use the find method for last cells...

Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
    LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function

Open in new window


Applied as:
xNew_Row = LastRow(Sheets("Actual"))

Open in new window


and when I read "Big-Endian v. Little-Endian" i just seem to get a picture of Tee-Pees in my head :)
0
 

Author Comment

by:gisvpn
ID: 38773711
Hello Brian, The_Barman,

Thank you both for correction on the last row reference. I had had problems with this and it was driving me nuts, I was not sure why it was not going to the top of the page, but this has fixed it.

Many thanks!

GISVPN
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38773741
Thanks, gisvpn - a nice bonus!

The_Barman
Very nice code - 4 to 5 times faster than xlLastCell! (So why didn't you use it?!)
(Plus or minus - it doesn't detect some (blank) rows that Excel is happy to keep in the file, e.g. ="" - copy and pastespecial values.)

Regards,
Brian.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38773940
OK, just for fun I have coded the entire solution in array handling format (which should be the best possible solution)...

Option Explicit
Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
    LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function

Sub OK_y_run()
Dim xlast_Row As Long
Dim xNew_Row As Long
Dim i As Long, x As Long, counter As Long

Dim ws As Worksheet
Dim arr As Variant

Dim MyDictionary As Scripting.Dictionary
Set MyDictionary = New Scripting.Dictionary
MyDictionary.CompareMode = vbBinaryCompare
Set ws = Sheets("Names")
xlast_Row = LastRow(ws)
arr = ws.Range("A1:B" & xlast_Row).Value
For counter = 1 To UBound(arr, 1)
    If Not MyDictionary.Exists(arr(counter, 1)) Then MyDictionary.Add arr(counter, 1), arr(counter, 2)
Next

Set ws = Sheets("Data")
xlast_Row = LastRow(ws)
arr = ws.Range("A2:N" & xlast_Row).Value

If xlast_Row < 2 Then
    MsgBox ("No data to run against")
    Exit Sub
End If

Set ws = Sheets("Actual")
ws.Range("A4:H50000").ClearContents

Dim OutArr()
x = 0
ReDim OutArr(1 To 8, 1 To 1)
For i = 1 To UBound(arr)
    If arr(i, 8) = "IMMS" Then
        x = x + 1
        ReDim Preserve OutArr(1 To 8, 1 To x)
        OutArr(1, x) = arr(i, 5)
        OutArr(2, x) = MyDictionary.Item(arr(i, 6))
        OutArr(3, x) = arr(i, 6)
        OutArr(4, x) = arr(i, 3)
        OutArr(5, x) = arr(i, 7)
        OutArr(6, x) = ""
        OutArr(7, x) = arr(i, 2)
        OutArr(8, x) = arr(i, 1)
    End If
Next

ws.Range("A4:H" & x).Value = Application.Transpose(OutArr)

End Sub

Open in new window

0
 
LVL 26

Expert Comment

by:redmondb
ID: 38774069
The_Barman,

Again, very nice!

I thought beyond a certain point it was necessary to buffer the data, only reading in x rows at a time. But your code happily read in 320,000 rows (some 20mb).

(On the last cell issue, LastRow() doesn't handle comments and neither method handles merged cells.)

Edit: A couple of problems...
(1) The last three IMMS entries are not created in "Actual". (Just a matter of the output range.)
(2) Dates are messed up if the system date is in "dd/mm/yyyy" format. (To deal with this, it seems that the code would need to know which values are dates.)

Regards,
Brian
0
 
LVL 24

Expert Comment

by:Steve
ID: 38774971
Ahha, yes,
ws.Range("A4:H" & x).Value = Application.Transpose(OutArr)

Open in new window

needs to be
ws.Range("A4:H" & x + 3).Value = Application.Transpose(OutArr)

Open in new window


As for the dates... I hate how vba handles the dates sometimes.
It should just handle them as they are, will take a look at what can be done there.
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38775345
The_Barman,

It should just handle them as they are, will take a look at what can be done there.
I'd love to see a clean, generic solution!

Regards,
Brian.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38775404
Yep. dates are a bugger.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38775562
OK, Brian has been kind enough to take me to school here on the output of the file... attached is the file correcting the date format issue which I had missed, thanks to Brian for sticking at this to get the right answer rather than just one that looks right.

Option Explicit
Private Function LastRow(TheWorksheet As Worksheet) As Long
If WorksheetFunction.CountA(TheWorksheet.Cells) > 0 Then
    LastRow = TheWorksheet.Cells.Find(What:="*", After:=TheWorksheet.Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
End Function

Sub OK_y_run()
Dim xlast_Row As Long
Dim xNew_Row As Long
Dim i As Long, x As Long, counter As Long

Dim ws As Worksheet
Dim arr As Variant

Dim MyDictionary As Scripting.Dictionary
Set MyDictionary = New Scripting.Dictionary
MyDictionary.CompareMode = vbBinaryCompare
Set ws = Sheets("Names")
xlast_Row = LastRow(ws)
arr = ws.Range("A1:B" & xlast_Row).Value
For counter = 1 To UBound(arr, 1)
    If Not MyDictionary.Exists(arr(counter, 1)) Then MyDictionary.Add arr(counter, 1), arr(counter, 2)
Next

Set ws = Sheets("Data")
xlast_Row = LastRow(ws)
arr = ws.Range("A2:N" & xlast_Row).Value

If xlast_Row < 2 Then
    MsgBox ("No data to run against")
    Exit Sub
End If

Set ws = Sheets("Actual")
ws.Range("A4:H50000").ClearContents

Dim OutArr()
x = 0
ReDim OutArr(1 To 8, 1 To 1)
For i = 1 To UBound(arr)
    If arr(i, 8) = "IMMS" Then
        x = x + 1
        ReDim Preserve OutArr(1 To 8, 1 To x)
        OutArr(1, x) = Format(arr(i, 5), "dd-mmm-yyyy")
        OutArr(2, x) = MyDictionary.Item(arr(i, 6))
        OutArr(3, x) = arr(i, 6)
        OutArr(4, x) = arr(i, 3)
        OutArr(5, x) = arr(i, 7)
        OutArr(6, x) = ""
        OutArr(7, x) = arr(i, 2)
        OutArr(8, x) = arr(i, 1)
    End If
Next

ws.Range("A4:H" & x + 3).Value = Application.Transpose(OutArr)

End Sub

Open in new window

Example-1---Copying-Cells.xlsm
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38775570
The_Barman,

Looks like I'm on a lonely road in my quest for a generic answer!

Regards,
Brian.
0
 
LVL 24

Expert Comment

by:Steve
ID: 38775734
I would not give up yet Brian, but many have tried and cried as they try to get a simple solution. An Option Base DateFormat("dd/mm/yyyy") would be nice or something similar.
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38776323
The_Barman,

Been there, done that, dried my eyes.

I was never too bothered about simple, but I was looking for clean and, above all, accurate.

Regards,
Brian.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how to import an Outlook PST file to Office 365 using a third party product to avoid Microsoft's Azure command line tool, saving you time.
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question