search列标题，复制列并粘贴到主工作簿

如何将这些列标题名称“TOOL CUTTER”和“HOLDER”复制到列表（仅数据），并将它们粘贴到另一个工作簿表单中，其中VBA代码（Sheet Module）是。 谢谢。 列标题HOLDER出现在F10中（最好写为（10，6），而TOOL CUTTER在G10（10，11）中，但最好是search标题名称并打印该列中的任何内容，直到它是完全空的（可能会出现空格）任何帮助都非常感谢！

工作代码：打开循环中的文件夹中的文件 – 打开文件，将文件的名称打印到Masterfile表中，将项目J1从文件打印到Masterfile表格中，closures文件，打开文件夹中的下一个文件，直到全部循环。

Option Explicit Sub LoopThroughDirectory() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim MyFolder As String Dim Sht As Worksheet, ws As Worksheet Dim WB As Workbook Dim i As Integer Dim LastRow As Integer, erow As Integer Dim Height As Integer Application.ScreenUpdating = False MyFolder = "C:\Users\trembos\Documents\TDS\progress\" Set Sht = Workbooks("masterfile.xlsm").Sheets("Sheet1") 'create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'get the folder object Set objFolder = objFSO.GetFolder(MyFolder) i = 1 'loop through directory file and print names For Each objFile In objFolder.Files If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then 'print file name Workbooks.Open Filename:=MyFolder & objFile.Name Set WB = ActiveWorkbook With WB For Each ws In .Worksheets Sht.Cells(i + 1, 1) = objFile.Name With ws .Range("J1").Copy Sht.Cells(i + 1, 4) End With i = i + 1 Next ws .Close SaveChanges:=False End With End If Next objFile Application.ScreenUpdating = True End Sub 

代码我正在尝试在HOLDER和TOOL CUTTER列中输出值（返回错误）工具variables没有在行中定义For Each Tool In TOOLList中，在以注释开头的块中粘贴find的TOOL列表这张表：

 Option Explicit Sub LoopThroughDirectory() Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim MyFolder As String Dim StartSht As Worksheet, ws As Worksheet Dim WB As Workbook Dim i As Integer Dim LastRow As Integer, erow As Integer Dim Height As Integer 'Application.ScreenUpdating = False MyFolder = "C:\Users\trembos\Documents\TDS\progress\" Set StartSht = ActiveSheet 'create an instance of the FileSystemObject Set objFSO = CreateObject("Scripting.FileSystemObject") 'get the folder object Set objFolder = objFSO.GetFolder(MyFolder) i = 2 'loop through directory file and print names For Each objFile In objFolder.Files If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then 'print file name StartSht.Cells(i, 1) = objFile.Name Dim NewWb As Workbook Set NewWb = Workbooks.Open(Filename:=MyFolder & objFile.Name) 'print TDS values With WB For Each ws In .Worksheets StartSht.Cells(i + 1, 1) = objFile.Name With ws .Range("J1").Copy StartSht.Cells(i + 1, 4) End With i = i + 1 Next ws .Close SaveChanges:=False End With End If 'print CUTTING TOOL and HOLDER lists Dim k As Long Dim width As Long Dim TOOLList As Object Dim count As Long Set TOOLList = CreateObject("Scripting.Dictionary") Dim ToolRow As Integer 'set as As Long if more than 32767 rows ' search for all on other sheets ' Assuming header means Row 1 If objFile.Name <> "masterfile.xls" Then 'skip any processing on "Masterfile.xls" For Each ws In NewWb.Worksheets 'assuming we want to look through the new workbook With ws width = .Cells(10, .Columns.count).End(xlToLeft).Column For k = 1 To width If Trim(.Cells(10, k).Value) = "CUTTING TOOL" Then Height = .Cells(.Rows.count, k).End(xlUp).Row If Height > 1 Then For ToolRow = 2 To Height If Not TOOLList.exists(.Cells(ToolRow, k).Value) Then TOOLList.Add .Cells(ToolRow, k).Value, "" End If Next ToolRow End If End If Next End With Next End If ' paste the TOOL list found back to this sheet With StartSht width = .Cells(10, .Columns.count).End(xlToLeft).Column For k = 1 To width If Trim(.Cells(10, k).Value) = "CUTTING TOOL" Then Height = .Cells(.Rows.count, k).End(xlUp).Row count = 0 For Each Tool In TOOLList count = count + 1 .Cells(Height + count, k).Value = Tool Next End If Next End With 'close current file, do not save changes NewWb.Close SaveChanges:=False i = i + 1 'move to next file Next objFile 'Application.ScreenUpdating = True End Sub 

Answer 1

将一些不同的任务重构成单独的函数，可以让代码更清晰，更易于遵循。

编译但未经testing：

 Option Explicit Sub LoopThroughDirectory() Const SRC_FOLDER As String = "C:\Users\trembos\Documents\TDS\progress\" Const ROW_HEADER As Long = 10 Dim f As String Dim StartSht As Worksheet, ws As Worksheet Dim WB As Workbook Dim i As Integer Dim dict As Object Dim hc As Range, hc2 As Range, d As Range Set StartSht = ActiveSheet i = 3 f = Dir(SRC_FOLDER & "*.xls*", vbNormal) 'get first file name 'find the header on the master sheet Set hc2 = HeaderCell(StartSht.Cells(ROW_HEADER, 1), "CUTTING TOOL") If hc2 Is Nothing Then MsgBox "No header found on master sheet!" Exit Sub End If 'loop through directory file and print names Do While Len(f) > 0 If f <> ThisWorkbook.Name Then Set WB = Workbooks.Open(SRC_FOLDER & f) For Each ws In WB.Worksheets StartSht.Cells(i, 1) = f ws.Range("J1").Copy StartSht.Cells(i, 4) i = i + 1 'find the header on the source sheet Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL") If Not hc Is Nothing Then Set dict = GetUniques(hc.Offset(1, 0)) If dict.count > 0 Then Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) 'add the values to the master list d.Resize(dict.count, 1).Value = Application.Transpose(dict.keys) End If Else 'header not found on source worksheet End If Next ws WB.Close savechanges:=False End If 'not the master file f = Dir() 'next file Loop End Sub 'get all unique column values starting at cell c Function GetUniques(ch As Range) As Object Dim dict As Object, rng As Range, c As Range, v Set dict = CreateObject("scripting.dictionary") For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells v = Trim(c.Value) If Len(v) > 0 And Not dict.exists(v) Then dict.Add v, "" End If Next c Set GetUniques = dict End Function 'find a header on a row: returns Nothing if not found Function HeaderCell(rng As Range, sHeader As String) As Range Dim rv As Range, c As Range For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells If Trim(c.Value) = sHeader Then Set rv = c Exit For End If Next c Set HeaderCell = rv End Function 

Answer 2

“工具刀具”和“保持器”的值总是在第10行？ 在这些列中总会有值吗？ 你需要允许列中的空白值以外的例外吗？

同时，这里有几件事要尝试：

 Sub macro1() Dim Sht As Worksheet Dim LR As Integer, FR As Integer, ToolCol As Integer Set Sht = ActiveSheet With Sht 'Find column with TOOL CUTTER: ToolCol = Application.WorksheetFunction.Match("TOOL CUTTER", .Range("10:10"), 0) LR = .Cells(.Rows.Count, ToolCol).End(xlUp).Row 'Find last row with data in TOOL CUTTER column: .Range(.Cells(11, ToolCol), .Cells(LR, ToolCol)).Copy End With End Sub