I have a spreadsheet with lots of sheets and data, the first cell of each row always being a date. I have made a control sheet (Control CUSTOM), where user types two dates into cells B3 and C3, and then the macro would search all the sheets in the workbook for rows having first cell value BETWEEN these dates, then copy and paste the rows to the summary sheet (Data CUSTOM).
Yet it doesn't work as intended. The macro manages to find correct rows, and copy them, but it pastes it always to the same row, therefore overwriting itself. It also pastes them to wrong sheet (Control CUSTOM).
So far my code looks like this:
Sub DataSearch()
Dim lngLastRow As Long, lngRow As Long
Dim strColumn As String
Dim WS_Count As Integer
Dim I As Integer
Dim NextRow As Variant
Dim Date1 As Variant
Dim Date2 As Variant
Date1 = Sheets("Control CUSTOM").Range("B3")
Date2 = Sheets("Control CUSTOM").Range("C3")
' Set correct row for paste, always the next empty row
' Set WS_Count equal to the number of worksheets in the active workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
strColumn = "A"
With ActiveWorkbook.Worksheets(I)
lngLastRow = .Cells(.Rows.Count, strColumn).End(xlUp).Row
For lngRow = 2 To lngLastRow
Set NextRow = Range("A" & Sheets("Data CUSTOM").UsedRange.Rows.Count + 1)
If IsDate(.Cells(lngRow, strColumn).Value) And .Cells(lngRow, strColumn).Value >= Date1 And .Cells(lngRow, strColumn).Value <= Date2 Then
.Rows(lngRow).Copy
NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
Application.CutCopyMode = False
End If
Next lngRow
End With
Next I
End Sub
Hope you guys can help me. I have some experience with VBA, but all these multiple loops this propably needs just goes way over my head.
If you address these two issues with your NextRow
range variable your code should be ok.
For performance you might want to consider autofiltering the rows and copying in a block rather than testing line by line.
You also might want to exclude your two control sheets from the macro for good coding practice.
Dim NextRow As Variant
to
Dim NextRow As Range
and change
NextRow.PasteSpecial Paste:=xlValues, Transpose:=False
to
Set NextRow = Sheets("Data Custom").Range("A" & Sheets("Data CUSTOM").UsedRange.Rows.Count + 1)
As brettdj mentioned, to fix this issue you should add
Sheets("Data Custom").
to
Set NextRow = Range("A" & Sheets("Data CUSTOM").UsedRange.Rows.Count + 1)
so that it reads:
Set NextRow = Sheets("Data Custom").Range("A" & Sheets("Data CUSTOM").UsedRange.Rows.Count + 1)
By adding Sheets("Data Custom").
you are telling the macro that this range is NOT on the current worksheet (with is the inherent assumption).
Also, I'd recommend a couple of additional tweaks:
ThisWorkbook
instead of ActiveWorkbook
to ensure that you haven't accidentally activated another workbook .UsedRange
property...EVER. It's much more preferable to either increment a counter as you go or to do something similar to what you did earlier with lngLastRow = .Cells(.Rows.Count, strColumn).End(xlUp).Row
. The reason for this is because Excel defines the .UsedRange
based on things like formatting and the biggest range that has ever been used. As such, if you had a bunch of values in a range, and then cleared the values from the last row, it would still be considered part of the used range. Dim NextRow As Variant
to Dim NextRow As Range
since NextRow is always a Range object and doesn't vary. (courtesy of brettdj) Add the following code to the beginning of your method (after getting the date values):
Application.ScreenUpdating = False Application.Calculation = xlCalculationManual
And right before the end of the sub:
Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic
This tells Excel to stop SHOWING the changes that it's making to the workbook and to stop updating/calculating any formulas until after it's done running the macro. This will be a huge performance gain.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.