將不相鄰的數據單元格復制到一個工作簿中

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 中的查找，請使用宏記錄器，然后調整生成的代碼。