Solved

Copying Across Data via VBA

Posted on 2013-01-13
21
256 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
Comment Utility
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
Comment Utility
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
Comment Utility
Hi, gisvpn.

Please see attached.

Regards,
Brian.Example-1---Copying-Cells-V2.xlsm
0
 

Author Comment

by:gisvpn
Comment Utility
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
Comment Utility
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
Comment Utility
Thank you for the two examples, it is useful to know both ;)
0
 
LVL 24

Expert Comment

by:Steve
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

 

Author Comment

by:gisvpn
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
Yep. dates are a bugger.
0
 
LVL 24

Expert Comment

by:Steve
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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

Enabling OSINT in Activity Based Intelligence

Activity based intelligence (ABI) requires access to all available sources of data. Recorded Future allows analysts to observe structured data on the open, deep, and dark web.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

744 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now