我正在使用 Windows 笔记本电脑通过 SharePoint 运行 Excel 365 Web 浏览器。我无法通过 Web 浏览器运行 VBA，因此我使用“打开到桌面”来运行 VBA。
工作簿以客户的名字命名。工作簿电子表格的形式相同，并以员工命名。一个客户可能会被很多员工看到。每个工作簿可以包含 1 到 15 个电子表格。 150 个客户就是 150 份工作簿，我审查 30 名员工的工作。
我的流程是将员工完成的客户工作簿中的某些单元格复制到每月工作簿中。客户工作簿中的员工选项卡将附加到每月工作簿中。
子ConsolidateClientData()
Dim wsCounselor As Worksheet, wsMonthly As Worksheet
Dim clientWB As Workbook, monthlyWB As Workbook
Dim clientFolderPath As String, fileName As String
Dim clientWs As Worksheet, cWsName As String
Dim lastRowMonthly As Long, i As Long, rowOffset As Long
Dim dayService As Range, milesTraveled As Range, hoursTraveled As Range
Dim clientName As String, typeService As String
' Path to the folder where client workbooks are stored
clientFolderPath = "C:\Your\Path\To\ClientWorkbooks\" ' <-- Change this to your folder path
' Set reference to the open monthly workbook
Set monthlyWB = ThisWorkbook
' Loop through all the files in the client folder
fileName = Dir(clientFolderPath & "*.xlsx")
Do While fileName <> ""
' Open each client workbook
Set clientWB = Workbooks.Open(clientFolderPath & fileName)
Debug.Print "Opened: " & clientWB.Name ' For debugging
' Loop through all the sheets (counselor tabs) in the client workbook
For Each clientWs In clientWB.Sheets
cWsName = clientWs.Name ' Get counselor tab name
Debug.Print "Processing tab: " & cWsName ' For debugging
' Find the corresponding worksheet in the monthly workbook by counselor's name
On Error Resume Next
Set wsCounselor = monthlyWB.Sheets(cWsName)
On Error GoTo 0
If wsCounselor Is Nothing Then
' Debugging: If the worksheet is not found, notify
Debug.Print "No matching tab found in monthly workbook for: " & cWsName
Else
' Get Client's Name (C6) and Type of Service (F2)
clientName = clientWs.Range("C6").Value
typeService = clientWs.Range("F2").Value
Debug.Print "Client Name: " & clientName & " | Service: " & typeService
' Get the ranges for Day, Miles Traveled, and Hours Traveled
Set dayService = clientWs.Range("A11:A22")
Set milesTraveled = clientWs.Range("K11:K22")
Set hoursTraveled = clientWs.Range("F11:F22")
' Find the last row in the monthly workbook for appending data
lastRowMonthly = wsCounselor.Cells(wsCounselor.Rows.Count, "A").End(xlUp).Row
Debug.Print "Appending data to row: " & lastRowMonthly + 1
' Loop through each row (day of service) in the current client sheet
For i = 1 To dayService.Cells.Count
If dayService.Cells(i).Value <> "" Then ' Skip empty rows
rowOffset = lastRowMonthly + i
wsCounselor.Cells(rowOffset, 1).Value = dayService.Cells(i).Value ' Day service provided (A11:A22)
wsCounselor.Cells(rowOffset, 2).Value = clientName ' Client's name (C6)
wsCounselor.Cells(rowOffset, 3).Value = typeService ' Type of service (F2)
wsCounselor.Cells(rowOffset, 4).Value = milesTraveled.Cells(i).Value ' Miles traveled (K11:K22)
wsCounselor.Cells(rowOffset, 5).Value = hoursTraveled.Cells(i).Value ' Hours traveled (F11:F22)
End If
Next i
' Clear the wsCounselor reference for the next loop
Set wsCounselor = Nothing
End If
Next clientWs
' Close the client workbook
clientWB.Close SaveChanges:=False
' Move to the next workbook in the folder
fileName = Dir
Loop
MsgBox "Consolidation Complete"
结束子
以下是我如何让这个 VBA 工作的一些细节。我在笔记本电脑上使用 Excel 365 运行 VBA，它运行客户的电子表格，打开和关闭它们，调出每月工作簿，并重复该过程遍历所有客户工作簿。每月工作簿未接收或附加数据。
在我的装有 Microsoft Office Professional Plus 2019 的 Windows 10 桌面上。该程序打开客户的工作簿并开始完美地复制到每月工作簿，我非常喜欢它。然后，尝试再次运行它，但从那以后它就不起作用了。
我希望它能在装有 Excel 365 的笔记本电脑上运行，这是我每天上班时所用的笔记本电脑。如果没有，那么我想使用装有 Excel 2019 的家用台式电脑。我只需要把工作带回家即可。
lastRowMonthlyrowOffset标准模块，例如
Module1modMainOption Explicit
Sub ConsolidateClientData()
' Define constants.
Const SRC_FOLDER_PATH As String = "C:\Your\Path\To\ClientWorkbooks\"
Const SRC_FILE_PATTERN As String = "*.xlsx"
Dim SRC_CELLS() As Variant: SRC_CELLS = VBA.Array("C6", "F2")
Dim SRC_COLUMNS() As Variant: SRC_COLUMNS = VBA.Array("A", "F", "K")
Const SRC_ROWS As String = "11:22"
Const DST_COLUMN As String = "A"
' Reference the destination workbook (monthly).
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
' Retrieve the name of the first file (workbook) in the source folder.
Dim SourceFileName As String:
SourceFileName = Dir(SRC_FOLDER_PATH & SRC_FILE_PATTERN)
' Exit if no file was found.
If Len(SourceFileName) = 0 Then
MsgBox "No files matching the pattern """ & SRC_FILE_PATTERN _
& """ in """ & SRC_FOLDER_PATH & """ found!", vbExclamation
Exit Sub
End If
' Calculate the number of source rows
' to be able to define the array.
Dim sRowsCount As Long:
sRowsCount = dwb.Worksheets(1).Range(SRC_ROWS).Rows.Count
' Calculate the number of source (destination) columns
' to be able to define the array.
Dim ColumnsCount As Long:
ColumnsCount = UBound(SRC_CELLS) + UBound(SRC_COLUMNS) + 2 ' zero-based
' Define the array.
Dim Data() As Variant: ReDim Data(1 To sRowsCount, 1 To ColumnsCount)
' Create an instance of the 'clientData' user-defined type.
Dim client As clientData
' Populate its constant properties,
' the arrays holding the source cell addresses and source columns.
With client
.CellAddresses = SRC_CELLS
.ColumnStrings = SRC_COLUMNS
End With
Application.ScreenUpdating = False
' Declare additional variables.
Dim swb As Workbook, sws As Worksheet, dws As Worksheet
Dim dRowsCount As Long ' the number of non-blank rows to copy
' For each file apply the same logic...
Do While SourceFileName <> ""
' Open the source (client) workbook.
Set swb = Workbooks.Open(SRC_FOLDER_PATH & SourceFileName)
' Loop through the WORKSHEETS of the source workbook.
For Each sws In swb.Worksheets
' Reference the corresponding destination sheet.
RefWorksheet dwb, dws, sws.Name
If Not dws Is Nothing Then ' the destination sheet was found
' Read from the source sheet (ranges).
PopulateClient client, sws, SRC_ROWS
' Write to the destination array.
PopulateArray client, Data, dRowsCount, sRowsCount
' Write to the destination sheet (range).
PopulateRange dws, DST_COLUMN, Data, dRowsCount, ColumnsCount
Else ' the destination sheet was not found
Debug.Print "No sheet named """ & sws.Name _
& """ found in workbook """ & dwb.Name & "!"
End If
Next sws
swb.Close SaveChanges:=False ' it was just read from
SourceFileName = Dir ' read next file (workbook) name
Loop
Application.ScreenUpdating = True
' Inform.
MsgBox "Consolidation Complete"
End Sub
标准模块，例如
Module2modHelpOption Explicit
' Indices of the Source Arrays
Private Enum sCells
ClientName
ServiceType
End Enum
Private Enum sColumns
DayService
Hours
Miles
End Enum
' Actual Destination Columns
Private Enum dColumnIDs
DayService = 1
ClientName
ServiceType
Miles
Hours
End Enum
' Each Client (Worksheet)
Type clientData
' Constant
CellAddresses() As Variant
ColumnStrings() As Variant
' Each Sheet
Name As String
ServiceType As String
DayService() As Variant
Miles() As Variant
Hours() As Variant
End Type
Sub RefWorksheet( _
ByVal wb As Workbook, _
ByRef ws As Worksheet, _
ByVal SheetName As String)
Set ws = Nothing
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
End Sub
Sub PopulateClient( _
ByRef client As clientData, _
ByVal ws As Worksheet, _
ByVal RowsAddress As String)
With client
.Name = ws.Range(.CellAddresses(sCells.ClientName)).Value
.ServiceType = ws.Range(.CellAddresses(sCells.ServiceType)).Value
Dim rg As Range: Set rg = ws.Rows(RowsAddress)
.DayService = rg.Columns(.ColumnStrings(sColumns.DayService)).Value
.Hours = rg.Columns(.ColumnStrings(sColumns.Hours)).Value
.Miles = rg.Columns(.ColumnStrings(sColumns.Miles)).Value
End With
End Sub
Sub PopulateArray( _
client As clientData, _
ByRef Data() As Variant, _
ByRef dRowsCount As Long, _
ByVal sRowsCount As Long)
With client
dRowsCount = 0 ' reset ('ByRef')
Dim sRow As Long
For sRow = 1 To sRowsCount
If Len(CStr(.DayService(sRow, 1))) > 0 Then ' not blank
dRowsCount = dRowsCount + 1
Data(dRowsCount, dColumnIDs.DayService) = .DayService(sRow, 1)
Data(dRowsCount, dColumnIDs.ClientName) = .Name
Data(dRowsCount, dColumnIDs.ServiceType) = .ServiceType
Data(dRowsCount, dColumnIDs.Miles) = .Miles(sRow, 1)
Data(dRowsCount, dColumnIDs.Hours) = .Hours(sRow, 1)
End If
Next sRow
End With
End Sub
Sub PopulateRange( _
ByRef ws As Worksheet, _
ByVal Col As String, _
Data() As Variant, _
ByVal RowsCount As Long, _
ByVal ColumnsCount As Long)
If RowsCount > 0 Then
Dim cell As Range:
Set cell = ws.Cells(ws.Rows.Count, Col).End(xlUp).Offset(1)
cell.Resize(RowsCount, ColumnsCount).Value = Data
End If
End Sub