Saya memiliki beberapa file Excel dalam satu folder dan semuanya memiliki templat yang sudah diperbaiki. Saya ingin mengambil sel dari mereka dan kemudian memasukkan buku kerja baru.

Saya menggunakan 2 file Excel sebagai contoh dalam folder untuk menjelaskan. Saya memiliki folder bernama MyFolder dan dua file Excel di dalamnya. (file1.xlsx dan file2.xlsx)

pic1

pic2

Yang saya inginkan seperti:

pic3

Jadi, saya mencoba:

Sub Merge_Files()
Dim FSO As New FileSystemObject
Dim xFolder As Folder
Dim xFile As File
Dim Main_WB As Workbook, New_WB As Workbook
Dim X As Integer, Y As Integer
Set Main_WB = ActiveWorkbook
Set xFolder = FSO.GetFolder("C:\Desktop\MyFolder\") 

    Cells(1, "A").Value = "Company"
    Cells(1, "B").Value = "CB"
    Cells(1, "C").Value = "N/R"
    Cells(1, "D").Value = "BB"
    Cells(1, "E").Value = "Contact"
    Cells(1, "F").Value = "BT"
    Cells(1, "G").Value = "TypeAAAUnit"
    Cells(1, "H").Value = "AAAJob1_Max"
    Cells(1, "I").Value = "AAAJob1_Min"
    Cells(1, "J").Value = "AAAJob1_BR50"
    'I omit some parts here.
    Cells(1, "V").Value = "Total P/per person"

For Each xFile In xFolder.Files
    Set New_WB = Workbooks.Open(xFile.Path)
        Main_WB.Sheets(1).Range("A" & X).Value = New_WB.Sheets(1).Range("C1").Value
        Main_WB.Sheets(1).Range("B" & X).Value = New_WB.Sheets(1).Range("C2").Value
        Main_WB.Sheets(1).Range("C" & X).Value = New_WB.Sheets(1).Range("C3").Value
        Main_WB.Sheets(1).Range("D" & X).Value = New_WB.Sheets(1).Range("C4").Value
        Main_WB.Sheets(1).Range("E" & X).Value = New_WB.Sheets(1).Range("C5").Value
        Main_WB.Sheets(1).Range("F" & X).Value = New_WB.Sheets(1).Range("C6").Value
        Main_WB.Sheets(1).Range("G" & X).Value = New_WB.Sheets(1).Range("B11").Value
        Main_WB.Sheets(1).Range("H" & X).Value = New_WB.Sheets(1).Range("D11").Value
        Main_WB.Sheets(1).Range("I" & X).Value = New_WB.Sheets(1).Range("E11").Value
        Main_WB.Sheets(1).Range("J" & X).Value = New_WB.Sheets(1).Range("F11").Value
        Main_WB.Sheets(1).Range("V" & X).Value = New_WB.Sheets(1).Range("O23").Value
        New_WB.Close SaveChanges:=False
    Next xFile
End Sub

Namun, itu tidak berhasil, jadi saya memodifikasi beberapa bagian dari kode saya. saya menghapus

Main_WB.Sheets(1).Range("A" & X).Value = New_WB.Sheets(1).Range("C1").Value

Dan mengubahnya menjadi:

ActiveCell.Offset(xRow, 0) = xFolder.Sheets(1).Range("C1").Value
ActiveCell.Offset(xRow, 1) = xFolder.Sheets(1).Range("C2").Value
ActiveCell.Offset(xRow, 2) = xFolder.Sheets(1).Range("C3").Value    
'repeat so omit...
xRow = xRow + 1

Namun, itu masih tidak berfungsi. Saya ingin langsung mengambil setiap sel karena dalam dua file Excel ini, ada banyak sel dan tidak berurutan. Ada solusi?

1
Peter Chen 28 Desember 2017, 06:06

1 menjawab

Jawaban Terbaik

X perlu ditingkatkan. Saya juga memfaktorkan ulang kode menggunakan Pernyataan Dengan untuk keterbacaan yang lebih baik.

Sub Merge_Files()
    Dim FSO As New FileSystemObject
    Dim xFolder As Folder
    Dim xFile As File
    Dim Main_WB As Workbook, New_WB As Workbook
    Dim X As Integer, Y As Integer
    Set Main_WB = ActiveWorkbook

    Set xFolder = FSO.GetFolder("C:\Desktop\MyFolder\")
    X = 1
    With Main_WB.Worksheets(1)
        .Range("A" & X).Value = "Company"
        .Range("B" & X).Value = "CB"
        .Range("C" & X).Value = "N/R"
        .Range("D" & X).Value = "BB"
        .Range("E" & X).Value = "Contact"
        .Range("F" & X).Value = "BT"
        .Range("G" & X).Value = "TypeAAAUnit"
        .Range("H" & X).Value = "AAAJob1_Max"
        .Range("I" & X).Value = "AAAJob1_Min"
        .Range("J" & X).Value = "AAAJob1_BR50"
        .Range("V" & X).Value = "Total P/per person"

        For Each xFile In xFolder.Files
            X = X + 1
            Set New_WB = Workbooks.Open(xFile.Path)
            .Range("A" & X).Value = New_WB.Sheets(1).Range("C1").Value
            .Range("B" & X).Value = New_WB.Sheets(1).Range("C2").Value
            .Range("C" & X).Value = New_WB.Sheets(1).Range("C3").Value
            .Range("D" & X).Value = New_WB.Sheets(1).Range("C4").Value
            .Range("E" & X).Value = New_WB.Sheets(1).Range("C5").Value
            .Range("F" & X).Value = New_WB.Sheets(1).Range("C6").Value
            .Range("G" & X).Value = New_WB.Sheets(1).Range("B11").Value
            .Range("H" & X).Value = New_WB.Sheets(1).Range("D11").Value
            .Range("I" & X).Value = New_WB.Sheets(1).Range("E11").Value
            .Range("J" & X).Value = New_WB.Sheets(1).Range("F11").Value
            .Range("V" & X).Value = New_WB.Sheets(1).Range("O23").Value
            New_WB.Close SaveChanges:=False
        Next xFile

    End With
End Sub
3
user6432984user6432984 28 Desember 2017, 03:27