![](/img/trans.png)
[英]VBA - copy different template sheets from a workbook, into multiple sheets of another workbook based on criteria on a summary excel sheet
[英]Excel VBA macro to copy specific rows from workbook sheets into new summary sheet…almost works
我需要能够查看工作簿的每个工作表中指定范围的单元格,如果它们满足条件,则将该行复制到摘要表中。 下面的代码在大多数情况下都有效,除了在少数情况下复制不符合条件的行和在某些情况下跳过应复制的行。
有没有一种使用调试工具的方法,以便在循环浏览代码的任何时间都可以看到:什么是活动工作表? 什么是活动细胞? 什么是活动行? 等等
另外,我是否应该使用-For范围内的每个单元格而不是-While Len-来遍历每张纸上的指定范围?
Sub LoopThroughSheets()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim ws As Worksheet
'Start copying data to row 2 in HH (row counter variable)
LCopyToRow = 2
For Each ws In ActiveWorkbook.Worksheets
'Start search in row 7
LSearchRow = 7
While Len(ws.Range("M" & CStr(LSearchRow)).Value) > 0
'If value in column M > 0.8, copy entire row to HH
If ws.Range("M" & CStr(LSearchRow)).Value > 0.8 Then
'Select row in active Sheet to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into HH in next row
Sheets("HH").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to active ws to continue searching
ws.Activate
End If
LSearchRow = LSearchRow + 1
Wend
Next ws
'Position on cell A1 in sheet HH
Sheets("HH").Select
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
End Sub
关于调试的第一个问题,可以使用:
Debug.Print "Worksheet: " & ActiveSheet.Name
您可以随时在代码中将您所在的工作表打印到Visual Basic编辑器的“立即”窗口中。 这对于在所有情况下进行调试都非常有用。
其次,For Each循环是循环遍历任何事物的最快方法,但它也有缺点。 也就是说,如果您要删除/插入任何内容,它将返回有趣的结果(可以复制/粘贴)。 如果您对要处理多少行没有预先确定的想法,则最好使用任何一种While循环。
就您的代码而言,这就是我的方法(您仍然需要在while循环的上方和下方包含您的代码):
Dim Items As Range
Dim Item As Range
'This will set the code to loop from M7 to the last row, if you
'didn't want to go to the end there is probably a better way to do it.
Set Items = ws.Range("M7:M26")
For Each Item In Items
'If value in column M > 0.8, copy entire row to HH
If Item.Value > 0.8 Then
'Select row in active Sheet to copy
Item.EntireRow.Copy
'Paste row into HH in next row
Sheets("HH").Rows(LCopyToRow & ":" & LCopyToRow).PasteSpecial
'Move counter to next row
LCopyToRow = LCopyToRow + 1
End If
Next Item
与前面的答案非常相似,只是措辞有所不同,尽管结果相同。
Sub Button1_Click()
Dim Rws As Long, Rng As Range, ws As Worksheet, sh As Worksheet, c As Range, x As Integer
Set ws = Worksheets("HH")
x = 2
Application.ScreenUpdating = 0
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
Rws = .Cells(Rows.Count, "M").End(xlUp).Row
Set Rng = .Range(.Cells(7, "M"), .Cells(Rws, "M"))
For Each c In Rng.Cells
If c.Value > 0.8 Then
c.EntireRow.Copy Destination:=ws.Cells(x, "A")
x = x + 1
End If
Next c
End With
End If
Next sh
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.