如何复制两个不相邻列以及这些单元格左侧的单元格中包含数字的每个单元格，并将其粘贴到一个新列中

Question

由于各种原因，我需要一个宏来打开一个单独的工作簿，并从符合条件（包含数字）的两个不同列（D 和 I）中提取单元格，以及包含单元格的所述数字左侧的单元格（C 和 H）并将所有内容粘贴到新工作簿的 2 列（而不是 4 列）中。当 C 和 H 位于包含数字的 D 或 I 列单元格旁边时，C 和 H 包含文本。 D 列和 I 列中的单元格可以包含数字、文本或空白。然后我需要将它们粘贴到工作簿中，该工作簿将宏包含在从单元格 AT2 开始的 2 列（AT 和 AU）中。

我有一个对话框，提示用户选择源数据所需的工作簿（因为它会在一年中多次更改）。代码挂起的地方是在 Set copyrng = (sell:selloff) 时，它给了我一个语法错误。我想说，问题是我还没有“设置出售”任何东西，但我不确定我需要将其设置为什么，因为它不会是一个单一的单元格。我对 VBA 还很陌生，主要是从互联网上获取内容并进行调整以满足我的需要。

由于语法错误，到目前为止我还无法运行代码。

Dim Filename As String
    Dim Sheet As Worksheet
    Dim fldr As FileDialog
    Dim Message As String: Message = "Would you like to import new data?"
    Dim Ans
        Ans = MsgBox(Message, vbYesNo)
        
    Application.ScreenUpdating = False
    
    If Ans = vbYes Then
        
     Set fldr = Application.FileDialog(msoFileDialogFilePicker)
     With fldr
        .Title = "Select Current Data Sheet"
        .Show
        
        Dim FolderPath As String
        If .SelectedItems.Count <> 0 Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "Please select a file, even if it's the old one.  Otherwise, hit No on the first prompt"
        
        End If
     End With

        FolderPath = fldr.SelectedItems(1)
        Filename = Dir(FolderPath & "*.xlsx")
        
        Dim UNdest As Variant
        Dim sell As Range
        Dim selloff As Range
        Dim copyrng As Range
        Dim dastination As Range
        
        Set UNdest = Workbooks("Master Tracker").Sheets("Data").Range("AT2" & Rows.Count).End(xlUp).Offset(1)
        
           
        Do While Filename <> ""
            Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
            Workbooks(Filename).Activate
            
            For Each sell In Range("D:D")
                If IsNumeric(sell.Value) Then
                    Set selloff = sell.Offset(-1, 0)
                    Set copyrng = (sell:selloff)
                    copyrng.Copy UNdest
                Else 'should be skipping the cell if it doesn't contain a number
                End If
            Next sell
            
            Workbooks(Filename).Close
            Filename = Dir()

        Loop
    
    Else
    End If
    
    
    Application.ScreenUpdating = True
    
End Sub

如果代码混乱或令人困惑，我们深表歉意。总的来说，我的编码经验很少，一直在尝试使用 VBA 来让我们的操作运行得更流畅。因此，我实际上是从不同的论坛复制粘贴和修改来回答问题，而不是尝试学习理解。希望有一天我能做到这一点。任何帮助表示赞赏。谢谢！

Answer 1

我试图遵循你的VB的意图，是将多个Excel文件中的数据集导入到“Master Tracker”下的Data表中。尝试下面的代码是否有帮助，

Sub importdata()
    Dim Filename As String
    Dim Sheet As Worksheet
    Dim fldr As FileDialog
    Dim Message As String: Message = "Would you like to import new data?"
    Dim Ans
    Ans = MsgBox(Message, vbYesNo)
    
    Application.ScreenUpdating = False
    
    If Ans = vbYes Then
        
        Set fldr = Application.FileDialog(msoFileDialogFilePicker)
        With fldr
            .Title = "Select Current Data Sheet"
            .Show
            
            Dim FolderPath As String
            If .SelectedItems.Count <> 0 Then
                FolderPath = .SelectedItems(1)
            Else
                MsgBox "Please select a file, even if it's the old one.  Otherwise, hit No on the first prompt"
                Exit Sub
            End If
        End With
        
        FolderPath = fldr.SelectedItems(1)
        Filename = Dir(FolderPath & "*.xlsx")
        
        Dim UNdest As Range
        Dim sell As Range
        Dim selloff As Range
        Dim copyrng As Range
        Dim destination As Range
        
        Set UNdest = Workbooks("Master Tracker").Sheets("Data").Range("AT2").End(xlDown).Offset(1)
        
        Do While Filename <> ""
            Workbooks.Open Filename:=FolderPath & Filename, ReadOnly:=True
            Set Sheet = ActiveSheet
            
            For Each sell In Sheet.Range("D:D")
                If IsNumeric(sell.Value) Then
                    Set selloff = sell.Offset(0, -1)
                    Set copyrng = Sheet.Range(sell, selloff)
                    Set destination = UNdest.Resize(copyrng.Rows.Count, 2)
                    destination.Value = copyrng.Value
                    Set UNdest = UNdest.Offset(copyrng.Rows.Count)
                End If
            Next sell
            
            Workbooks(Filename).Close SaveChanges:=False
            Filename = Dir()
        Loop
    
    End If
    
    Application.ScreenUpdating = True
End Sub