Solved

Copying Across Data via VBA

Posted on 2013-01-13
21
277 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
  • 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
Master Your Team's Linux and Cloud Stack!

The average business loses $13.5M per year to ineffective training (per 1,000 employees). Keep ahead of the competition and combine in-person quality with online cost and flexibility by training with Linux Academy.

 

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

NAS Cloud Backup Strategies

This article explains backup scenarios when using network storage. We review the so-called “3-2-1 strategy” and summarize the methods you can use to send NAS data to the cloud

Question has a verified solution.

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

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

803 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