仍然是一个新手,在写这篇文章的过程中偶然发现了意外的成功,但仍然会发布它,以尝试了解更多有关自动过滤器以及条件引用如何在循环/其他条件事物中工作的信息。另外希望这篇文章可以帮助其他人。
我正在尝试编写一个 VBA 宏,该宏将根据要复制的行中的单元格 N(x) 是否包含数值,将行从工作簿 1 复制到工作簿 2。 基本上,我正在尝试创建一个数据库来跟踪我们是否收到了多余的样本,然后将其存储在内部。
在工作簿1中,如果收到的样品数的值高于发货的样品数,则余数将显示在“N”列中。如果不是,则返回“”。我想将第 N 列中返回值的任何行复制到 workbook2。
我发现了很多关于根据条件复制行的帖子,但当我修改它时,我似乎无法让任何代码工作。 下面是我尝试修改的两个不完整代码的示例。 (我在写这篇文章时不小心完成了第二个代码,但我不确定为什么它现在突然起作用了......)
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
上面的代码基于下面链接的帖子。我似乎无法弄清楚如何将过滤条件纳入此“Criteria1:=(If IsNumeric(Range("N" & i).Value) = True)”的工作版本,这是不正确的,只是我敲击键盘试图让它工作...... https://www.mrexcel.com/board/threads/help-need-vba-code-to-copy-rows-to-a-new-worksheet-based-on-criteria.359760/
我的第一次尝试是使用条件复制和粘贴。它卡在粘贴行上,给我一个错误 13 类型不匹配消息。我变了
ESwksht.Range(R).Offset(1).PasteSpecial Paste:=xlPasteValues
到
ESwksht.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
现在它可以工作了,不知道为什么...工作代码如下。
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
上面的代码是根据这两篇文章修改的。 https://www.mrexcel.com/board/threads/vba-conditional-copy-paste.468926/ VBA 将符合条件的行复制到另一张工作表
复制列中带有数字的行(仅限值)
Sub CopyIfNumberRows()
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 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
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
WasDataCopied = True
WriteMessage:
Application.ScreenUpdating = True
If WasDataCopied Then
MsgBox "If-number rows copied.", vbInformation
Else
MsgBox "No if-number rows found.", vbExclamation
End If
End Sub
复制列中包含非 Nlank 单元格的行(值、格式和公式)
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