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

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种类型的指定数据，例如名称，姓氏（它们始终在A18到D18和A19到D19中始终处于固定位置，第三个是查找日期，但是日期几乎总是在数据表中的不同位置，因此我希望添加一个代码的一部分，使它搜索诸如“ end 20190808”之类的内容，它将始终以end结尾，但始终位于diff行甚至列中。我还需要根据从最新（最旧）到最旧的日期排列数据（底部）并用文字而非数字表示日期的月份，例如六月 深深地感激任何形式的帮助，但如果可能的话，可以添加到我的编码中的一小段代码将使其变得更加容易，因为我的任务是在非常有限的时间内完成此任务 谢谢！！！

Answer 1

这里有一些代码执行与您描述的内容类似的代码。动画的.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

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