搜索列标题、复制列并粘贴到主工作簿

Question

如何复制具有这些列标题名称“TOOL CUTTER”和“HOLDER”的列（仅数据）并将它们粘贴（作为附加在每个列中，每个列具有相同的列标题名称）到另一个VBA 代码（工作表模块）所在的工作簿工作表。谢谢。 列标题 HOLDER 出现在 F10 中（最好写为 (10, 6)，而 TOOL CUTTER 在 G10 (10, 11) 中，但最好让它搜索标题名称并打印该列中的任何内容，直到它完全为空（可能会出现空格）。 非常感谢任何帮助！

工作代码：循环打开文件夹中的文件 - 打开文件，将文件名打印到 Masterfile 表，将项目 J1 从文件打印到 Masterfile 表，关闭文件，打开文件夹中的下一个文件，直到所有文件都循环通过。

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 列中的值的代码（返回错误 Tool variable is not defined in line For Each Tool In TOOLList in the block that start with the comment 'paste the TOOL list found back到这张纸：

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

将一些不同的任务重构为单独的函数可以使您的代码更简洁，更易于遵循。

已编译但未经测试：

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

值“TOOL CUTTER”和“HOLDER”是否总是在第 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