搜索列標題，複製列並粘貼到主工作簿

Question

如何複製含有這些列標題名稱「刀具刀具」和「保持器」的列（僅限數據）並將它們粘貼（作爲附加在一列中每個具有相同的列標題名稱）放入VBA代碼（Sheet Module）所在的另一個工作簿表單中。謝謝。 列標題HOLDER出現在F10中（最好寫爲（10，6），而TOOL CUTTER在G10（10，11）中，但最好讓它搜索標題名稱並打印該列中的任何內容，直到它是完全空的（可能會出現空格） 非常感謝任何幫助!!

工作代碼：打開循環中的文件夾中的文件 - 打開文件，將文件的名稱打印到Masterfile表中，從文件打印項目J1到主文件表，關閉文件，文件夾中，直到所有已通過循環打開下一個文件。我正在

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 

代碼嘗試打印值在支架和TOO大號刀具支柱（返回錯誤工具變量不符合For Each Tool In TOOLList在與評論開始塊定義「粘貼工具列表中找到回這片：

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

是值‘滾刀’和「持有人「總是在第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 

Answer 2

重構了一些不同的任務爲單獨的功能讓你的代碼更清潔和更容易理解。

編譯但未經檢驗：

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