将不相邻的数据单元格复制到一个工作簿中

Question

这是我目前正在使用的代码，但它不足以实现我的目标，我被困在如何继续......

因此，此代码将以 xlsx 的形式将许多其他 excel 工作簿中的指定数据复制到主 excel 工作簿中，在此之前它将扫描包含所有不同数据文件和主文件的文件夹（所有文件应该被传输此处以表格形式）例如 ScanFiles 文件夹中的 Test3.xlsx、Test4.xlsx、Test.xlxs 和 Main.xlsm。 所以每次有新文件进入文件夹时，它会通过打开数据工作簿自动更新主工作簿，然后复制所需的数据并在单击按钮时将其粘贴到主工作簿上。

Sub ScanFiles()
Dim myFile As String, path As String
Dim erow As Long, col As Long

path = "c:\Scanfiles\"
myFile = Dir(path & "*.xlsx")

Application.ScreenUpdating = False

Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate

Set copyrange = Sheets("sheet1").Range("A18,B18,C18,D18,A19,B19,C19,D19")

Windows("master-wbk.xlsm").Activate

erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

col = 1
For Each cel In copyrange
cel.Copy

Cells(erow, col).PasteSpecial xlPasteValues

col = col + 1

Next

Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

目标： 1st：原始类型的文件是“文件”而不是xlsx，所以希望在开始复制数据之前找到一种自动打开xlsx格式文件的方法。 第二：需要3种类型的指定数据，例如姓名，姓（它们都在固定的position中总是在A18到D18和A19到D19，第三个是找到日期，但是日期几乎总是在数据中的不同位置工作表，所以我希望在代码中添加一个部分，使其搜索“结束 20190808”之类的内容，它总是以结束开始，但总是在不同的行甚至列中。我还需要根据从最新（顶部）到最旧（底部）的日期和 state 日期的月份，用文字而不是数字表示，例如 6 月 深深感谢任何形式的帮助，但如果可能的话，可以添加到我的编码中的一小部分代码将使它容易多了，因为我的任务是在非常有限的时间内完成这项工作谢谢！！！

Answer 1

这是一些与您描述的内容相似的代码。 Animation.gif 显示它通过逐步执行代码来工作。 首先显示 2 个数据 (.xlsx) 文件，以便您了解它们的内容。 每个都与主工作簿位于同一文件夹中，并且在 A 列中有数据。然后当我们逐步打开每个文件的代码时，它的数据被处理（第 3 行被删除）并传输到主工作簿的相邻列中。 代码不限于.xlsx 文件，也可以处理文本文件，只要定义了ext 。

希望一旦您了解了它的工作原理，您可以对其进行修改以将其应用于您的案例。

Option Explicit
Sub CombineFiles()
Dim theDir As String, numFiles As Integer
Dim sh As Worksheet, wk As Workbook, newSheet As Worksheet
Dim newColumn As Range, r As Range, s As String
Const ext = ".xlsx"
    Err.Clear
    theDir = ThisWorkbook.Path
    Set newSheet = ThisWorkbook.Sheets.Add
    newSheet.Name = "Combined"
    Set newColumn = newSheet.Range("A1")
    'Loop through all files in directory
    s = Dir(theDir & "\*" & ext)
    While s <> ""
        numFiles = numFiles + 1
        On Error Resume Next
        Set wk = Workbooks.Open(theDir & "\" & s)
        Set sh = ActiveSheet
        sh.Rows(3).Delete Shift:=xlUp
        Set r = Range("A1")
        Range(r, r.End(xlDown)).Copy
        newSheet.Activate
        newColumn.Offset(0, numFiles) = wk.Name
        newColumn.Offset(1, numFiles).Select
        newSheet.Paste
        Application.DisplayAlerts = False
        wk.Close False
        Application.DisplayAlerts = True
        s = Dir()
    Wend
    MsgBox (numFiles & " files were processed.")
End Sub

有关图片的复制/粘贴，请参阅本页或本页上的示例。 要查找列中包含数据的最后一个单元格，请参阅此页面； 请注意，一个示例涉及使用 .find 命令。 更一般地说，要了解如何使用 vba 中的查找，请使用宏记录器，然后调整生成的代码。