Still a newb and have stumbled across accidental success in the middle of writing this post, but will still post it in an attempt to learn more about autofilter and how conditional references work inside loops/other conditional things. Plus hopefully this post can help someone else.
I'm trying to write a VBA macro that will copy rows from workbook1 to workbook2 based on if cell N(x) in the row to be copied holds a numeric value or not. Basically, I'm trying to create a database that tracks if we received excess samples which we then store in-house.
In workbook1, If the value of # of samples received is higher than the # shipped, the remainder is displayed in column "N". If not it returns "". I'd like to copy any row that returns a value in column N to workbook2.
I've found a bunch of posts on copying rows based on conditions, but I can't seem to get any of the code to work when I modify it. Below are two examples of incomplete code I've tried to modify. (I accidentally completed the second code while writing this post but I'm not sure why it suddenly works now...)
Sub ESWcopypaste()
Dim ESW As Workbook, AW As Workbook, Awksht As Worksheet, ESwksht As Worksheet
Dim LR As Long, i As Long
Dim R As Range
Set AW = ThisWorkbook
Set Awksht = AW.Worksheets("RECORDS")
Set R = Awksht.Range([A2], Range("A" & Rows.Count).End(xlUp)) <-"Have tried a few variations here. I still have a problem where it reads a cell with a formula that returns "" as numeric and includes them in the count..."
Workbooks.Open ("filepath to the ESW workbook")
Set ESW = Application.Workbooks("Extra Samples Catalog.xlsm")
Set ESwksht = ESW.Worksheets(3)
CR = ESwksht.Range("A" & Rows.Count).End(xlUp).Row <- "will be used to locate empty space to paste the contents, possible unnecessary when using autofilter"
On Error Resume Next
With R
LR = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
.AutoFilter , field:=1, Criteria1:=(If IsNumeric(Range("N" & i).Value) = True)
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Sheets("ESwksht").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
End Sub
The above code is based on the post linked below. I can't seem to figure out how to make the filter criteria into a working version of this "Criteria1:=(If IsNumeric(Range("N" & i).Value) = True)", which isn't correct, just me mashing the keyboard in an attempt to get it working... https://www.mrexcel.com/board/threads/help-need-vba-code-to-copy-rows-to-a-new-worksheet-based-on-criteria.359760/
My first attempt was to use conditional copy and paste. It was getting stuck at the line to paste, giving me a error 13 type mismatch message. I changed
ESwksht.Range(R).Offset(1).PasteSpecial Paste:=xlPasteValues
to
ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
and now it works, idk why though... Working code is below.
Sub CPESampleData()
Dim ESW As Workbook, AW As Workbook, Awksht As Worksheet, ESwksht As Worksheet
Dim LR As Long, i As Long
Dim R As Range
Set AW = ThisWorkbook
Set Awksht = AW.Worksheets("RECORDS")
Set R = Awksht.Range("A" & Rows.Count).End(xlUp)
Workbooks.Open ("C:filepath to Extra Samples Catalog.xlsm")
Set ESW = Application.Workbooks("Extra Samples Catalog.xlsm")
Set ESwksht = ESW.Worksheets(3)
CR = ESwksht.Range("A" & Rows.Count).End(xlUp).Row
AW.Activate
With AW.Sheets("RECORDS")
AW.Activate
LR = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LR
If IsNumeric(Range("N" & i).Value) = True Then
Awksht.Rows(i).Copy
ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
Next i
End With
ESwksht.Activate
End Sub
The code above was modified from these two posts. https://www.mrexcel.com/board/threads/vba-conditional-copy-paste.468926/ VBA copy rows that meet criteria to another sheet
Copy Rows With a Number in Column (Values Only)
IsEmpty(Range("A1").Value) or the equivalent in Excel ISBLANK(A1).IsNumeric(Range("A1").Value) but I mostly prefer the safer (more accurate) VarType(Range("A1").Value) = vbDouble.Sub CopyIfNumberRows()
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("RECORDS")
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
Dim Data As Variant: Data = sdrg.Value
Dim cCount As Long: cCount = UBound(Data, 2)
Dim sr As Long, dr As Long, c As Long, WasDataCopied As Boolean
For sr = 1 To UBound(Data, 1)
If VarType(Data(sr, 14)) = vbDouble Then ' is a number
dr = dr + 1
For c = 1 To cCount
Data(dr, c) = Data(sr, c)
Next c
End If
Next sr
If dr = 0 Then GoTo WriteMessage
Application.ScreenUpdating = False
Dim dwb As Workbook:
Set dwb = Workbooks.Open("C:\Test\Extra Samples Catalog.xlsm")
Dim dws As Worksheet: Set dws = dwb.Worksheets(3)
Dim dfcell As Range:
Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
Dim drg As Range: Set drg = dfcell.Resize(dr, cCount)
drg.Value = Data
'dwb.Close SaveChanges:=True
Application.ScreenUpdating = True
WasDataCopied = True
WriteMessage:
If WasDataCopied Then
MsgBox "If-number rows copied.", vbInformation
Else
MsgBox "No if-number rows found.", vbExclamation
End If
End Sub
Copy Rows With Non-Nlank Cell in Column (Values, Formatting and Formulas)
Sub CopyNonBlanksAutoFilter()
Application.ScreenUpdating = False
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("RECORDS")
sws.AutoFilterMode = False
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
Dim sdrg As Range: Set sdrg = strg.Resize(strg.Rows.Count - 1).Offset(1)
Dim svrg As Range, WasDataCopied As Boolean
strg.AutoFilter Field:=14, Criteria1:="<>"
On Error Resume Next
Set svrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
sws.AutoFilterMode = False
If svrg Is Nothing Then GoTo WriteMessage
Dim dwb As Workbook:
Set dwb = Workbooks.Open("C:\Test\Extra Samples Catalog.xlsm")
Dim dws As Worksheet: Set dws = dwb.Worksheets(3)
Dim dfcell As Range:
Set dfcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
svrg.Copy dfcell
'dwb.Close SaveChanges:=True
WasDataCopied = True
WriteMessage:
Application.ScreenUpdating = True
If WasDataCopied Then
MsgBox "Non-blanks copied.", vbInformation
Else
MsgBox "No non-blanks found.", vbExclamation
End If
End Sub