问候,
我已经找了很多代码来帮助我做到这一点,虽然我发现了一些暗示它的部分,也许这是我对 vba 的缺乏经验,但我无法修改任何适合我的东西。我有一本工作簿,里面有几张关于数量、零件、描述的工作表。数量在 a 列中。每个工作簿的前 3 行是一个标题。我希望在我的“摘要”工作表中有代码,用于搜索所有其他工作表并编译摘要表上的所有数量、部分和描述信息(列 a、b 和 c),所以基本上我最终得到从第 4 行开始,数量大于 0 的每个项目的摘要页面上的列表。任何提示或建议将不胜感激。
非常感谢,威廉
问候,
我已经找了很多代码来帮助我做到这一点,虽然我发现了一些暗示它的部分,也许这是我对 vba 的缺乏经验,但我无法修改任何适合我的东西。我有一本工作簿,里面有几张关于数量、零件、描述的工作表。数量在 a 列中。每个工作簿的前 3 行是一个标题。我希望在我的“摘要”工作表中有代码,用于搜索所有其他工作表并编译摘要表上的所有数量、部分和描述信息(列 a、b 和 c),所以基本上我最终得到从第 4 行开始,数量大于 0 的每个项目的摘要页面上的列表。任何提示或建议将不胜感激。
非常感谢,威廉
当我看到 eggplant_parm 已经回答了你时,我试图解决这个问题。顺便说一句,这是我的解决方案,与他的解决方案非常相似。
Option Explicit
Sub copy_info()
Dim i As Long, j As Long, lastRow As Long
Dim sh As Worksheet
With Sheets("Summary")
.Cells.Clear
.Range("A1") = "Quantity"
.Range("B1") = "Parts"
.Range("C1") = "Description"
.Range("D1") = "Sheet name"
.Range("A1:D1").Font.Bold = True
End With
j = 2
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> "Summary" Then
lastRow = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row
For i = 4 To lastRow
If sh.Range("A" & i) > 0 Then
sh.Range("a" & i & ":c" & i).Copy Destination:=Worksheets("Summary").Range("A" & j)
Sheets("Summary").Range("D" & j) = sh.Name
j = j + 1
End If
Next i
End If
Next sh
Sheets("Summary").Columns("A:D").AutoFit
End Sub
如果我正确理解您的设置,这应该可以工作。
Sub GetParts()
Application.ScreenUpdating = False
Dim W As Worksheet, r As Single, i As Single
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
If W.Cells(r, 1) > 0 Then
Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
i = i + 1
End If
Next r
End If
Next W
End Sub
有点长,但是我认为这种方法可以让您更轻松地修改代码,希望对您有所帮助。
Public Sub main()
'Using PrintCollection,ReadCollection and FilterCollection
PrintColl Ws:="Sheet3", _
coll:=FilterColl( _
coll:=ReadColl( _
WSs:=Array("Sheet1", "Sheet2"), _
fRow:=4, _
lRow:=-1, _
fCol:=1, _
lCol:=2)), _
fRow:=1, _
fCol:=3
End Sub
'Function to determine if table(index) should be included in the result.
Function MyFilter(ByRef table As Variant, ByVal index As Integer) As Boolean
If table(index, 1) > 0 Then
MyFilter = True
Else
MyFilter = False
End If
End Function
'Takes an array of worksheet names and 4 parameters that represent a range
'It asumes that Cols are adjacent and the data starts in the same row
'Pass a negative value to lRow to look down the first Col of every worksheet
'returns a Collection with WS names as key and arrays with the range values
Function ReadColl(ByRef WSs As Variant, _
ByVal fRow As Integer, ByVal lRow As Integer, _
ByVal fCol As Integer, ByVal lCol As Integer) As collection
Dim coll As New collection
Dim l As Integer
For i = 0 To UBound(WSs, 1)
If lRow < 0 Then
l = LastNumber(WSs(i), fRow, fCol)
Else
l = lRow
End If
coll.Add ReadTbl(WSs(i), fRow, l, fCol, lCol), WSs(i)
Next i
Set ReadColl = coll
End Function
'Read the values in a WS into an array
Function ReadTbl(ByVal Ws As String, _
ByVal fRow As Integer, ByVal lRow As Integer, _
ByVal fCol As Integer, ByVal lCol As Integer) As Variant
ActiveWorkbook.Worksheets(Ws).Select
Range(Cells(fRow, fCol), Cells(lRow, lCol)).Select
ReadTbl = Selection.Value
End Function
'Filter every table inside the collection supplied
Function FilterColl(ByRef coll As collection) As collection
Dim filtered As New collection
Dim table As Variant
For Each table In coll
filtered.Add (FilterTbl(table))
Next table
Set FilterColl = filtered
End Function
'Returns a new table composed by elements that make MyFilter true
Function FilterTbl(ByRef table As Variant) As Variant
Dim filtered As New collection
Dim elem() As Variant
ReDim elem(1 To UBound(table, 2))
For i = 1 To UBound(table, 1)
If MyFilter(table, i) = True Then
For j = 1 To UBound(table, 2)
elem(j) = table(i, j)
Next j
filtered.Add elem, CStr(i)
End If
Next i
FilterTbl = CollToTbl(filtered)
End Function
'Auxiliary function to solve array limitations in vba
Function CollToTbl(ByRef coll As collection) As Variant
If coll.Count > 0 Then
Dim ary() As Variant
Dim item As Variant
Dim nCols As Integer
nCols = UBound(coll(1), 1)
ReDim ary(1 To coll.Count, 1 To nCols)
For i = 1 To coll.Count
For j = 1 To nCols
ary(i, j) = coll(i)(j)
Next j
Next i
CollToTbl = ary
End If
End Function
'Takes Ws, a collection, and the first position where the result is expected
Sub PrintColl(ByVal Ws As String, ByRef coll As collection, _
ByVal fRow As Integer, ByVal fCol As Integer)
Dim pos As Integer
pos = fRow
ActiveWorkbook.Worksheets(Ws).Select
Selection.ClearContents
For i = 1 To coll.Count
PrintTbl Ws, coll(i), pos, fCol
pos = pos + UBound(coll(i), 1)
Next i
End Sub
'Same as before except it outputs an specific table
Sub PrintTbl(ByVal Ws As String, ByRef table As Variant, _
ByVal fRow As Integer, ByVal fCol As Integer)
ActiveWorkbook.Worksheets(Ws).Select
Range(Cells(fRow, fCol), _
Cells(fRow + UBound(table, 1) - 1, UBound(table, 2))).Select
Selection.Value = table
End Sub
'Iterates Col in the WS starting in fRow until IsNumber returns false
Function LastNumber(ByVal Ws As String, _
ByVal fRow As Integer, ByVal Col As Integer) As Integer
ActiveWorkbook.Worksheets(Ws).Select
While WorksheetFunction.IsNumber(Cells(fRow, Col).Value)
fRow = fRow + 1
Wend
LastNumber = fRow - 1
End Function