将多个工作簿中的值复制到母版中的特定单元格
Copying values from multiple workbooks to specific cells in a master
嗨嗨，
免责声明：我没有编码经验
我有一个代码，它从我桌面上一个文件夹中的多个工作表的单元格 (B2:C2) 中获取值，并将其粘贴到主工作簿中。这很好用，但是，我不希望将复制的单元格连续粘贴到单元格 (F3:G3) 中——它们需要粘贴到特定的单元格中。这听起来很复杂，我敢肯定。首先，这是我修改过的基本代码 (from this code) 以满足我的需要：
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.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”的工作簿复制到与这些值对应的单元格。为了澄清，我添加了我的主工作簿的 Screenshot。
如果它从标题包含 282579 和 Ch.4 的源工作簿中复制一个值，它将把这两个值粘贴到位于 (F10:G10) 的 282579 的 Ch.4 单元格中，依此类推。
尝试使用 If 函数（例如，If（工作簿的名称中有这个）但我不知道如何指定需要将其粘贴到哪些单元格中）
我希望我说得有道理并且这是可以理解的。
编辑：如果需要我使用的数据的副本，我可以提供
根据您的解释，不清楚您是否能够将源工作表与特定的 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.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()'
使用正则表达式提取 SN 和 Ch。文件名中的数字。使用“查找”在摘要中找到 SN sheet，然后扫描合并的行以查找 Ch 编号。
Sub MergeAllWorkbooks()
' Modify this folder path to point to the files you want to use.
Const FolderPath = "C:\Users\Me\Desktop\Extracted Data.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
嗨嗨， 免责声明：我没有编码经验 我有一个代码，它从我桌面上一个文件夹中的多个工作表的单元格 (B2:C2) 中获取值，并将其粘贴到主工作簿中。这很好用，但是，我不希望将复制的单元格连续粘贴到单元格 (F3:G3) 中——它们需要粘贴到特定的单元格中。这听起来很复杂，我敢肯定。首先，这是我修改过的基本代码 (from this code) 以满足我的需要：
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.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”的工作簿复制到与这些值对应的单元格。为了澄清，我添加了我的主工作簿的 Screenshot。 如果它从标题包含 282579 和 Ch.4 的源工作簿中复制一个值，它将把这两个值粘贴到位于 (F10:G10) 的 282579 的 Ch.4 单元格中，依此类推。 尝试使用 If 函数（例如，If（工作簿的名称中有这个）但我不知道如何指定需要将其粘贴到哪些单元格中）
我希望我说得有道理并且这是可以理解的。
编辑：如果需要我使用的数据的副本，我可以提供
根据您的解释，不清楚您是否能够将源工作表与特定的 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.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()'
使用正则表达式提取 SN 和 Ch。文件名中的数字。使用“查找”在摘要中找到 SN sheet，然后扫描合并的行以查找 Ch 编号。
Sub MergeAllWorkbooks()
' Modify this folder path to point to the files you want to use.
Const FolderPath = "C:\Users\Me\Desktop\Extracted Data.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