I have a working code for copying large amount of data from a monthly sheet to daily sheet. There are about 30 columns of data to be copied over 2000 rows. I don't know how I can speedup the job as it is taking about 3 minutes to copy even one column. I have to this for all 30 columns. The order of columns in monthly sheet is not same as in daily sheet; for eg. monthly sheet column D might represent column P of daily sheet. If the learned ones can help to improve the code I will be most grateful.
PJ
Sub COPY2()
Dim i As Long, j As Long, lastrow1 As Long, Lastrow2 As Long, myname As String
Dim SWB As Workbook, TWB As Workbook, Sws As Worksheet, Tws As Worksheet
Set SWB = ActiveWorkbook
Set Sws = SWB.Sheets("SHEET1")
Windows("DAILY.xlsX").Activate
Set TWB = ActiveWorkbook
Set Tws = TWB.Sheets("Sheet1")
lastrow1 = Sws.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = Tws.Range("A" & Rows.Count).End(xlUp).Row
Sws.Activate
For i = 2 To lastrow1
myname = Sws.Cells(i, "B").Value
Tws.Activate
For j = 2 To Lastrow2
If Tws.Cells(j, "D").Value = myname Then Tws.Cells(j, "P").Value = Sws.Cells(i, "D").Value
If Tws.Cells(j, "P").Value = Sws.Cells(i, "D").Value Then Exit For
Next j
Next i
End Sub
Excel operations take much time. Try to access data in blocks rather than cell by cell.
BTW activating sheets are useful while testing and debugging but it wastes your time when running the app live.
Try the snippet below. The concept is to read and manipulate data to buffers, and write back Excel in one single step when finished processing, so you can save thousends of Excel operations.
Dim sa(), tad(), tap()
lastrow1 = sws.Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = tws.Range("A" & Rows.Count).End(xlUp).Row
sws.Activate
sa = Range(sws.Cells(1, 2), sws.Cells(lastrow1, 4)) ' B:D columns
tad = Range(tws.Cells(1, "D"), tws.Cells(lastrow2, "D")) ' D column
tap = Range(tws.Cells(1, "P"), tws.Cells(lastrow2, "P")) ' P column
For i = 2 To lastrow1
For j = 2 To lastrow2
If tad(j, 1) = sa(i, 1) Then
tap(j, 1) = sa(i, 3)
Exit For
End If
Next j
Next i
Range(tws.Cells(1, "P"), tws.Cells(lastrow2, "P")) = tap
End Sub
Related
so I have this invoice form that looks like this in Sheet Invoice_Form of an Excel workbook InvoiceForm.xlsm:
and a database of invoice records in Sheet Invoice Database of an Excel workbook InvoiceDatabase.xlsm:
I have created VBA codes that can link records from the form to the invoice database, but what the code manages to do right now is only recording the first row of the invoice form:
The code looks like this:
Sub Submit_Invoice()
Dim LastRow As Long, ws As Worksheet
Set ws = Sheets("InvoiceDatabase")
LastRow = ws.Range("I" & Rows.Count).End(xlUp).Row + 1
ws.Range("K" & LastRow).Value = Worksheets("Invoice Form").Range("C9:C16").Value
ws.Range("L" & LastRow).Value = Worksheets("Invoice Form").Range("D9:D16").Value
....
End Sub
So the question is: How do I modify my code so that it can create multiple records on different rows based on this one form if there are additional products added in the invoice form?
Thanks!
Build an array from the form and dump the array into the InvoiceDatabase.
Sub Submit_Invoice()
Dim lr As Long, ws As Worksheet
dim arr as variant, i as long
with Worksheets("Invoice Form")
lr = .cells(16, "C").end(xlup).row - 8
redim arr(1 to lr, 1 to 6)
for i=lbound(arr,1) to ubound(arr, 1)
arr(i, 1) = .cells(5, "D").value
arr(i, 2) = .cells(6, "D").value
arr(i, 3) = .cells(i+8, "C").value
arr(i, 4) = .cells(i+8, "D").value
arr(i, 5) = .cells(i+8, "E").value
arr(i, 6) = .cells(i+8, "F").value
next i
end with
WITH WORKSheets("InvoiceDatabase")
lr = .Range("I" & .Rows.Count).End(xlUp).Row + 1
.cells(lr, "I").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You really should use a form/access database or Excel data form (2016) to do this.
That said, your code is overwriting each row as your write to the other sheet as it isn't incremented. Also, you are missing how you add dates and invoice numbers.
The following uses more meaningful names and adds in the missing data, along with some basic error checks (e.g. there is data to transfer) and housekeeping in terms of clearing the form after transfer.
Option Explicit
Public Sub Submit_Invoice()
Dim nextRowDest As Long, lastRowSource As Long, wsDest As Worksheet, wsSource As Worksheet, transferData As Range
Dim invoiceInfo As Range
Application.ScreenUpdating = False
Set wsDest = ThisWorkbook.Worksheets("InvoiceDatabase")
Set wsSource = Workbooks("Invoice_Form.xlsm").Worksheets("Invoice Form")
With wsSource
lastRowSource = wsSource.Range("C" & .Rows.Count).End(xlUp).Row
If lastRowSource < 9 Then Exit Sub '<==No data
Set transferData = .Range("C9:G" & lastRowSource)
Set invoiceInfo = .Range("D5:D6")
End With
With wsDest
nextRowDest = wsDest.Range("I" & Rows.Count).End(xlUp).Row + 1
If nextRowDest < 4 Then Exit Sub '<==Assume headers are in row 3
transferData.Copy .Range("K" & nextRowDest)
invoiceInfo.Copy
.Range("I" & nextRowDest).Resize(transferData.Rows.Count, invoiceInfo.Rows.Count).PasteSpecial Transpose:=True
End With
transferData.ClearContents
invoiceInfo.ClearContents
Application.ScreenUpdating = True
End Sub
This site has helped me immensely with VBA for a while now, so thanks for that! But I just can't seem to get this code to work and I've look at so many examples. What's happening is that I'm archiving data on another sheet once the current date is 4 days ahead of the due date. Everything works like it should, but every time the macro executes, the data on sheet2 is erased and copied over. I need my code to find the last row on sheet2 and copy the data from sheet1 to sheet2 so all the data is there. Thanks!
Sub archive()
Dim LastRow As Long
Dim i As Long
LastRow = Range("M" & Rows.Count).End(xlUp).Row
For i = 3 To LastRow
If Worksheets("Sheet1").Range("M" & i) - Date <= -4 And Worksheets("Sheet1").Range("N" & i).Value = "DONE" Then
Sheet2.Select
Range("A" & i).EntireRow.Value = Sheet1.Range("M" & i).EntireRow.Value
Sheet1.Range("M" & i).EntireRow.Delete
End If
If Worksheets("Sheet1").Range("L" & i) = "" Then
Exit For
End If
Next i
End Sub
Here I've taken your code and changed it to use worksheet objects. I've not tested this on any data as you haven't provided any to use, but it gives you an idea of how to implement it.
Also, in your code you weren't finding the last row of Sheet2, you were putting the data in row i, which starts at 3.
You also need to watch out when you delete the row of data from sheet1, as this shifts the rest of the data up, so the next iteration of the loop may not find the next row of data/ skip a row of data.
Sub archive()
Dim LastRow As Long
Dim LastRowSht2 As Long
Dim i As Long
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim rowCount As Long
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
LastRow = sht1.Range("M" & Rows.Count).End(xlUp).Row
rowCount = 3
For i = 3 To LastRow
If sht1.Range("M" & rowCount) - Date <= -4 And sht1.Range("N" & rowCount).Value = "DONE" Then
LastRowSht2 = sht2.Range("A" & Rows.Count).End(xlUp).Row + 1 '+1 so it doesn't overwrite the last row
sht2.Range("A" & LastRowSht2).EntireRow.Value = sht1.Range("M" & rowCount).EntireRow.Value
sht1.Range("M" & rowCount).EntireRow.Delete
Else
rowCount = rowCount + 1
End If
If sht1.Range("L" & rowCount) = "" Then
Exit For
End If
Next i
' clean up
set sht1 = nothing
set sht2 = nothing
End Sub
Thanks for accepting me in this forum.
I have a excel sheet which contains more than 90,000 rows as master traker.
my code is
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Dim mysegment As String
lastrow1 = wb3.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = wb3.Sheets(1).Cells(i, "A").Value
mysegment = wb3.Sheets(1).Cells(i, "B").Value
Wb2.Sheets(1).Activate
lastrow2 = Wb2.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Wb2.Sheets(1).Cells(j, "A").Value = myname And Wb2.Sheets(1).Cells(j, "B").Value = mysegment Then
wb3.Sheets(1).Activate
wb3.Sheets(1).Range(Cells(i, "C"), Cells(i, "M")).Copy
Wb2.Sheets(1).Activate
Wb2.Sheets(1).Range(Cells(j, "C"), Cells(j, "M")).Select
ActiveSheet.Paste
End If
Next j
Application.CutCopyMode = False
Next i
I need to update the Column C to K of master tracker using individual excel sheet which contains more than 1200 rows if the column A and B match.
I have used For and next loop for this.
However, it is taking so much time approximately 1 hour** to complete the task.
It will be grateful, if you resolve this issue.
Maybe try to disable screen update before loop :
Application.ScreenUpdating = False
And don't forget to enable them after loop, to let user modify the excel file :
Application.ScreenUpdating = True
General Approach
Create a separate worksheet with a Microsoft SQL Query which make the
relevant updates. OLEDB is significantly faster than VBA.
Copy the separate worksheet onto the master tracker.
If this is not feasible (for some reason) and it's an issues of code performance you can try many way of improving code performance: see my post here.
Last resort - VBA multithreading. See my post here.
Specific findings
Try modifying your code as follows:
Application.ScreenUpdating = False'!!!!
Application.Calculation = xlCalculationManual'!!!!
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long, myname As String, mysegment As String, ws2 as worksheet, ws3 as worksheet
Set ws3 = wb3.Sheets(1): Set ws2 = wb2.Sheets(1)
lastrow1 = ws3.Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = ws3.Cells(i, 1).Value
mysegment = ws2.Cells(i, 2).Value
For j = 2 To lastrow2
If ws2.Cells(j, 1).Value = myname And ws2.Cells(j, 2).Value = mysegment Then
ws3.Range("C" & i & ":M" & i)= ws2.Range("C" & i & ":M" & i)
End If
Next j
Next i
Application.Calculation = xlCalculationAutomatic'!!!!
Application.ScreenUpdating = True'!!!!
Further performance
I would "replace" the master tracker with a Microsoft Query simply writing a SQL like (draft):
SELECT Iif(IsNull(slave.A),master.A,slave.A),
Iif(IsNull(slave.A),master.B,slave.B),
Iif(IsNull(slave.A),master.C,slave.C),
etc......
FROM [Sheet1$] as master
LEFT OUTER JOIN `C:\slave.xlsx`.`Sheet1$1` as slave
ON master.A = slave.A and master.B = slave.B
This would be as fast as it gets. Probably a couple seconds maximum.
Feel free to play with my SQL Add-in to try: link.
I am trying to do some cuts to a sheet of data based on if a row meets 2 criteria in different columns, i.e. if the value in column D is > -2 and if the value in the adjacent cell of column F is > -2 or NA, then delete the entire row. If only 1 or none of the criteria is met then it should keep the row. Below is what i have so far. When i run the macro, it will go on forever, but I don't see how this should be since it doesn't look like an endless loop to me (to be fair i have only let it sit for 45 minutes, but there is only around 15,000 data rows so it shouldn't take longer than 10 minutes realistically). Any help would be greatly appreciated.
Sub Cuts()
Dim wb1 As Workbook, sh1 As Worksheet
Dim lastrow1 As Long, lastrow2 As Long
Set wb1 = Workbooks(“ovaryGisticARRAYRNAseq.final.xlsx")
Set sh1 = wb1.Sheets(“Cuts”)
lastrow1 = sh1.Cells(Rows.Count, 4).End(xlUp).Row
lastrow2 = sh1.Cells(Rows.Count, 6).End(xlUp).Row
For i = 1 To lastrow1
For j = 1 To lastrow2
If sh1.Cells(i, 4).Value > -2 Then
If sh1.Cells(j, 6).Value > -2 Then
sh1.Cells(j, 6).EntireRow.Delete
ElseIf sh1.Cells(j, 6).Value = “NA” Then
sh1.Cells(j, 6).EntireRow.Delete
End If
End If
Next j
Next i
End Sub
I'm not sure how you want to handle blank cells or text in column headings but I would propose this modification.
Sub Cuts()
Dim wb1 As Workbook
Dim lr As Long, i As Long
Set wb1 = Workbooks(“ovaryGisticARRAYRNAseq.final.xlsx")
With wb1.Sheets("Cuts")
lr = Application.Max(.Cells(Rows.Count, 4).End(xlUp).Row, _
.Cells(Rows.Count, 6).End(xlUp).Row)
For i = lr To 1 Step -1
If .Cells(i, 4).Value > -2 And _
(.Cells(i, 6).Value > -2 Or UCase(.Cells(i, 6).Value) = "NA") Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
I have a worksheet that can be updated. The user inputs a sheet number to real time update and then macro will look at Column 9 (I) and copy B:D of that row and paste it in cells on the front sheet (coverpage). This will continue until all data in the data sheet has run through.
Sub Update_Current()
Dim Page
Dim lastrow As Long, i As Long
Dim ws As Worksheet
lastrow = ActiveSheet.Range("D1000").End(xlUp).Row + 1
Page = InputBox("Which week would you like to update?")
If Page = 1 Then
Worksheets("Week(1)").Select
For i = 6 To 100
If ws.Cells(i, 9) = "2" Or ws.Cells(i, 9) = "3" Then
Range("i,2:1,4").Copy
{TORN ON WHAT GOES HERE}
End If
Next i
End If
End Sub
I know it is late but cannot leave a question without an answer when i think i have one. Hopefully this will help someone else.
Sub Update_Current()
Dim Page
Dim lastrow As Long, i As Long
Dim ws As Worksheet
Page = InputBox("Which week would you like to update?")
If Page = 1 Then
Set ws = Worksheets("Week(1)")
ws.Select
For i = 2 To 100
If ws.Cells(i, 9) = "2" Or ws.Cells(i, 9) = "3" Then
ws.Range("B" & i & ":D" & i).Copy
ThisWorkbook.Sheets("CoverPage").Select
lastrow = ThisWorkbook.Sheets("CoverPage").Range("D1000").End(xlUp).Row + 1
ThisWorkbook.Sheets("CoverPage").Range("B" & lastrow).PasteSpecial xlPasteValues
End If
Next i
End If
End Sub