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

Question

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

"If Sht <> "masterfile.xls" Then这行是问题所在。我从另一在线来源获得帮助， If ws.name <> me.name Then我显然应该在此处输入其他名称但我不知道是什么。

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

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

任何帮助是极大的赞赏！！

在此处找到以前的代码概述帮助： 搜索特定的列标题名称，复制列并粘贴以追加到另一个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 ， If Sht <> "masterfile.xls" Then则打算跳过WorkBook masterfile.xls的处理，然后：

  • If Sht.Cells(i, 1) <> "masterfile.xls" Then就可以解决这个问题，因为您早先在代码中存储了文件名。 （注意：使用i后，您立即将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