嗨， 免責宣告：我沒有編碼經驗 我有一個代碼，它從我桌面上一個檔案夾中的多個作業表的單元格 (B2:C2) 中獲取值并將其粘貼到主作業簿中。這很好用，但是，我不希望復制的單元格連續粘貼到單元格 (F3:G3) - 它們需要粘貼到特定的單元格中。這聽起來很復雜，我敢肯定。首先，這是我修改過的基本代碼（從此代碼中）以滿足我的需要：
Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set SummarySheet = ActiveWorkbook.ActiveSheet
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\Me\Desktop\Extracted Data\16.12.2021\"
' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.csv*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'loop through all Sheets in WorkBk
For Each sh In WorkBk.Worksheets
' Set the source range to be A9 through C9.
Set SourceRange = Sheets(sh.Name).Range("B2:C2")
' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("F" & SummarySheet.Range("F" & Rows.Count).End(xlUp).Row 1)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
Next sh
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
ActiveSheet.Columns.AutoFit
'Message Box when tasks are completed
MsgBox "Task Complete!"
End Sub
因此，這會運行并將值從源檔案夾中的每個作業簿復制到主檔案夾。我想這樣做：如果它從包含“282579”和“Ch.4”的作業簿復制到與這些值對應的單元格。為了澄清，我添加了我的主作業簿的螢屏截圖。如果它從標題包含 282579 和 Ch.4 的源作業簿中復制一個值，它會將這兩個值粘貼到位于 (F10:G10) 的 282579 的 Ch.4 單元格中，依此類推。嘗試使用 If 函式（如 If（作業簿名稱中有這個），但我不知道如何指定需要粘貼的單元格）
我希望我說得有道理并且這是可以理解的。
編輯：如果需要我使用的資料的副本，我可以提供
uj5u.com熱心網友回復：
使用正則運算式提取 SN 和 Ch。檔案名中的數字。使用 Find 在匯總表上找到 SN，然后掃描合并的行以獲取 Ch 編號。
Sub MergeAllWorkbooks()
' Modify this folder path to point to the files you want to use.
Const FolderPath = "C:\Users\Me\Desktop\Extracted Data\16.12.2021\"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, wsCSV As Worksheet
Dim rngCSV As Range, fnd As Range, bFound As Boolean
Dim Filename As String, n As Long, i As Long
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
' regular expression to extract numbers
' example VS SAAV_282579 ch 4 Data.csv
Dim Regex As Object, m As Object, SN As Long, CH As Long
Set Regex = CreateObject("vbscript.regexp")
With Regex
.IgnoreCase = True
.Pattern = "(_(\d ) ch (\d ) Data)"
End With
' Call Dir the first time, pointing it to all Excel files in the folder path.
Filename = Dir(FolderPath & "*Data.csv*")
' Loop until Dir returns an empty string.
Application.ScreenUpdating = False
Do While Filename <> ""
' extract SN and Ch from filename
If Regex.test(Filename) Then
Set m = Regex.Execute(Filename)(0).submatches
SN = m(1)
CH = m(2)
Debug.Print Filename, SN, CH
' Find SN
Set fnd = ws.Range("B:B").Find(SN, LookIn:=xlValues, lookat:=xlWhole)
If fnd Is Nothing Then
MsgBox SN & " not found !", vbCritical, Filename
Else
' find ch.
bFound = False
For i = 0 To fnd.MergeArea.Count - 1
If ws.Cells(fnd.Row i, "D") = CH Then ' Col D
bFound = True
' Open a workbook in the folder
Set wbCSV = Workbooks.Open(FolderPath & Filename, ReadOnly:=True)
ws.Cells(fnd.Row i, "F").Resize(, 2).Value2 = wbCSV.Sheets(1).Range("B2:C2").Value2
' Close the source workbook without saving changes.
wbCSV.Close savechanges:=False
Exit For
End If
Next
If bFound = False Then
MsgBox "Ch." & CH & " not found for " & SN, vbExclamation, Filename
End If
End If
n = n 1
Else
Debug.Print Filename & " skipped"
End If
' Use Dir to get the next file name.
Filename = Dir()
Loop
' Call AutoFit on the destination sheet so that all
' data is readable.
ws.Columns.AutoFit
Application.ScreenUpdating = True
'Message Box when tasks are completed
MsgBox n & " csv files found.", vbInformation, "Task Complete!"
End Sub
uj5u.com熱心網友回復：
根據您的解釋，尚不清楚您是否能夠將源作業表與特定的 Ch 匹配。如果可以，我建議在 For each sh 回圈之后不久定義一個 Ch 變數，然后您需要在主作業簿中 D 列的每一行啟動另一個回圈，直到獲得 Ch 變數的行號。您使用行號來定義目標范圍
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim n As Long 'Ch substring position
Dim Ch As String 'Ch variable for source file
Dim LastChRow As Long 'lastrow of Ch in summary sheet
Dim ChSummary As String 'Define the Ch string in summary sheet
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Set summarysheet to activeworkbook/activesheet where the macro runs
Set SummarySheet = ActiveWorkbook.ActiveSheet
' Define LastChRow
LastChRow = SummarySheet.Cells(Rows.Count, "D").End(xlUp).Row
' Modify this folder path to point to the files you want to use.
FolderPath = "C:\Users\Me\Desktop\Extracted
Data\16.12.2021\"
' Call Dir the first time, pointing it to all Excel files in the
folder path.
FileName = Dir(FolderPath & "*.csv*")
' Loop until Dir returns an empty string.
Do While FileName <> ""
'define starting charachter of Ch source file for string manipulation
n = InStr(FileName, "Ch")
'define Ch variable
Ch = Trim(Mid(FileName, n, 5))
' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'loop through all Sheets in WorkBk
For Each sh In WorkBk.Worksheets
For i = 3 To LastChRow
'Define ChSummary variable in loop
ChSummary = "Ch" & " " & SummarySheet.Range("D" & i)
If ChSummary = Ch Then
' Set the source range to be A9 through C9.
Set SourceRange = Sheets(sh.Name).Range("B2:C2")
' Set the destination range to start at column B and
' be the same size as the source range.
Set DestRange = SummarySheet.Range("F" & i & ":G" & i)
'Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
' SourceRange.Columns.Count)
' Copy over the values from the source to the destination.
DestRange.Value = SourceRange.Value
End If
Next i
Next sh
' Close the source workbook without saving changes.
WorkBk.Close savechanges:=False
' Use Dir to get the next file name.
FileName = Dir()'
轉載請註明出處，本文鏈接：https://www.uj5u.com/qianduan/383989.html
下一篇：檢查日期是否超過7個作業日