从多个工作表复制到单独的工作簿
我需要编写一些代码以运行特定工作簿的每个工作表,并将特定单元复制到单独的工作簿。我无法指定要复制到的目标工作表。我有什么至今:从多个工作表复制到单独的工作簿
Private Sub CommandButton1_Click()
Dim wb As Workbook, wbhold As Workbook
Dim ws As Worksheet, wshold As Worksheet
Dim holdCount As Integer
Dim cellColour As Long
Dim cell As Range, rng As Range
Set wb = Workbooks.Open("blahblah.xls")
Set wbhold = Workbooks.Open("blahblah2.xlsm")
holdCount = 0
cellColour = RGB(255, 153, 0)
rownumber = 0
For Each ws In wb.Worksheets
With ws
Set rng = ws.Range("A1:A20")
For Each cell In rng
rownumber = rownumber + 1
If cell.Interior.Color = cellColour Then
Range("A" & rownumber & ":B" & rownumber).Select
Selection.Copy
wbhold.Activate
Sheets("Hold Data").Activate
Cells.Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 10
wb.Activate
End With
holdCount = holdCount + 1
End If
Next cell
End With
Next ws
Application.DisplayAlerts = False
wb.Close
MsgBox "found " & holdCount
End Sub
但行:Sheets("Hold Data").Activate
不断抛出了一个“下标越界”的错误。我一直在玩代码大约2个小时,试图让它起作用,但无济于事。有任何想法吗?
这应该做你想要快一点什么:
Private Sub CommandButton1_Click()
Dim wb As Workbook, wbhold As Workbook
Dim ws As Worksheet, wshold As Worksheet
Dim holdCount As Integer
Dim cellColour As Long
Dim cell As Range, rng As Range
Dim outrow As Long
Application.ScreenUpdating = False
Set wb = Workbooks.Open("blahblah.xls")
Set wbhold = Workbooks.Open("blahblah2.xlsm")
Set wshold = wbhold.Worksheets("Hold Data")
holdCount = 0
cellColour = RGB(255, 153, 0)
outrow = 1
For Each ws In wb.Worksheets
Set rng = Nothing
With ws
For Each cell In .Range("A1:A20")
If cell.Interior.Color = cellColour Then
If rng Is Nothing Then
Set rng = cell.resize(, 2)
Else
Set rng = Union(rng, cell.Resize(, 2))
End If
holdCount = holdCount + 1
End If
If Not rng Is Nothing Then
rng.Copy wshold.Cells(outrow, "A")
outrow = outrow + rng.Cells.Count \ 2
End If
Next cell
End With
Next ws
With wshold.Cells(1, "A").CurrentRegion.Font
.Name = "Arial"
.Size = 10
End With
wb.Close False
Application.ScreenUpdating = True
MsgBox "found " & holdCount
End Sub
'Set wshold = wbhold.Worksheets(“Hold Data”)' – WaltVinegar
'出现“下标超出范围”错误然后工作表名称错误。 – Rory
只需再次检查,表格名称匹配。我之前也在使用我的代码获取该错误,这就是为什么在原始问题上删除该行的原因。 – WaltVinegar
你在哪里实际上是试图粘贴到 - 哪些细胞? – Rory
它只需要开始粘贴到A1和B1 [它只是复制每行的两个数据单元],然后在循环的每次迭代中向下移动一行。我是VBA的总新手[因为你可以说],所以它需要的时间比它应该。 – WaltVinegar