vba - 搜索特定列标题，复制列并粘贴到另一个工作簿

Question

如何复制具有这些列标题名称“TOOL CUTTER”和“HOLDER”的列(仅数据)并将它们粘贴(作为仅一列的附加，每个列具有相同的列标题名称)到另一个工作簿工作表中，其中VBA代码(工作表模块)是。谢谢。

线路"If Sht <> "masterfile.xls" Then是问题发生的地方。我从另一个在线来源获得了帮助，该行是 If ws.name <> me.name Then显然我本想在这里起一个不同的名字，但我不知道是什么。

不需要是这种解决方法，这只是我目前拥有的。

我正在打开多个文件，这就是为什么我主要使用 ActiveSheet 方法而不是 Sheet1 Sheet2 的原因。我的代码所在的文件名为“masterfile.xls”

非常感谢任何帮助!!

以前的代码大纲帮助可以在这里找到:Search for specific column header names, copy columns and paste to append to another wookbooksheet

Sub LoopThroughDirectory()

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim Sht As Worksheet
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer

    'Speed up process by not updating the screen
    'Application.ScreenUpdating = False

    MyFolder = "C:\Users\trembos\Documents\TDS\progress\"

Set Sht = ActiveSheet

    '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" And LCase(Left(Right(objFile.Name, 4), 3)) <> "xls" Then
        Else
            'print file name
            Sht.Cells(i + 1, 1) = objFile.Name
            i = i + 1
            Workbooks.Open fileName:=MyFolder & objFile.Name

        End If

        Dim k As Long
        Dim width As Long
        Dim ws As Worksheet
        Dim TOOLList As Object
        Dim count As Long
        Set TOOLList = CreateObject("Scripting.Dictionary")

        ' search for all tel/number list on other sheets
        ' Assuming header means Row 1
        For Each ws In Worksheets
            If Sht <> "masterfile.xls" Then
                With ActiveSheet
                    .Activate
                    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 j = 2 To Height
                                    If Not TOOLList.exists(.Cells(j, k).Value) Then
                                        TOOLList.Add .Cells(j, k).Value, ""
                                    End If
                                Next j
                            End If
                        End If
                    Next
                End With
            End If

        Next

        ' paste the TOOL list found back to this sheet
        With masterfile.xls
            .Activate
            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








        'Range("J1").Select
        'Selection.Copy
        'Windows("masterfile.xlsm").Activate
        'Range("D2").Select
        'ActiveSheet.Paste
        ActiveWorkbook.Close SaveChanges:=False

        Next objFile

'Application.ScreenUpdating = True

End Sub

Answer 1

• sht引用此代码所在工作簿中的事件工作表，因为 Set Sht = ActiveSheet

• sht是一个对象变量，并且永远不会等于字符串值 "masterfile.xls"

• sht.name将为您提供工作表的(字符串)名称，您可以将其与字符串值 "masterfile.xls" 进行比较，但这仍然不会告诉你你在追求什么，因为:

  • 您混淆了 WorkSheet 的名称( sht.name ) 文件名为 WorkBook (masterfile.xls)。

• If LCase(Right(objFile.Name, 3)) <> "xls" And Case(Left(Right(objFile.Name, 4), 3)) <> "xls" Then Else是一个非常尴尬的结构。将其更改为:

  • If LCase(Right(objFile.Name, 3)) = "xls" or Case(Left(Right(objFile.Name, 4), 3)) = "xls" Then并消除else条款。这将使它更具可读性

• 我认为 If Sht <> "masterfile.xls" Then旨在跳过 WorkBook masterfile.xls 的处理如果是这样的话:

  • If Sht.Cells(i, 1) <> "masterfile.xls" Then应该可以解决问题，因为您之前在代码中存储了文件名。 (注意:使用 i 后您会立即增加它，因此您必须在此处使用一个较小的值。)
• Workbooks.Open fileName:=MyFolder & objFile.Name将打开新工作簿，但很容易混淆您正在查看的工作簿。试试Set NewWb = Workbooks.Open fileName:=MyFolder & objFile.Name ，现在你有了一个坚实的句柄来引用这个。
• With ActiveSheet
.Activate简直是多余的。 ActiveSheet是事件工作表，无需激活它。
• With masterfile.xls是一个完全非功能性的语句。 With期望某种集合对象可以使用，masterfile.xls不是。它不是一个字符串(没有引号)，它不是任何类型的变量(从未声明)，它不是具有方法或属性(xls)的对象(主文件)。这表明您没有 Option Explicit设置在代码的顶部。您应该始终这样做，因为这会导致编译时错误而不是运行时错误。
• 如果上述有效，ActiveWorkbook.Close SaveChanges:=False会关闭您正在运行的工作簿，因为您会激活它。

试试这个代码，它可能不是 100%，它至少应该让你更接近你想要的:

Option Explicit
Sub LoopThroughDirectory()

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer

    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)
        End If

        Dim k As Long
        Dim width As Long
        Dim ws As Worksheet
        Dim TOOLList As Object
        Dim count As Long
        Set TOOLList = CreateObject("Scripting.Dictionary")

        ' search for all tel/number list 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 j = 2 To Height
                                    If Not TOOLList.exists(.Cells(j, k).Value) Then
                                        TOOLList.Add .Cells(j, k).Value, ""
                                    End If
                                Next j
                            End If
                        End If
                    Next
                End With
            Next
        End If

        ' paste the TOOL list found back to this sheet
        With StartSheet
            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
        NewWb.Close SaveChanges:=False
        i = i + 1
    Next objFile

'Application.ScreenUpdating = True

End Sub