Thay đổi cách import dữ liệu (1 người xem)

[881516]

Em có nhờ làm đc 1 macro chạy, chức năng là tổng hợp dữ liệu từ các file được đặt trong 1 thư mục, setup sẵn đường link của thư mục nằm tại ô A1
Giờ em cần thay đổi cách nhập liệu này thành nhập theo file tùy chọn (nhập file mới nhưng dữ liệu cũ ko bị mất đi)
Nhờ mọi ng chỉnh lại giúp em ạ
Dưới đây là toàn bộ code của e, code hơi dài nhưng chủ yếu là lấy nhiều dữ liệu nên dài thôi ạ

Sub test()
Dim FolderPath As String, FileName As String, strFileTarget As String
Dim wb As Excel.Workbook
Dim i As Integer, lastRow As Integer
Dim DataArr(18) As String

FolderPath = Range("A1").Value & "\"        'Duong dan thu muc do tim
FileName = Dir(FolderPath & "*.xls*")       'Tim trong thu muc tat ca cac file *.xls*
strFileTarget = "IMEX - 2018 - Hung.xlsm"          'Ten file macro chay

Set FSO = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
If FSO.FolderExists(FolderPath) Then
  
    Do While FileName <> ""
        If FileName <> strFileTarget Then
      
            On Error Resume Next
            Set wb = Workbooks.Open(FolderPath & FileName)
            If Err.Number <> 0 Then: MsgBox ("Unable to open file " & FileName)
            On Error GoTo 0
            lastRow = Workbooks(strFileTarget).Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
          
    '        Workbooks(FileName).Worksheets(1).Range(Cells(5, 2), Cells(10, 2)).Copy
    '        Workbooks(strFileTarget).Worksheets(1).Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

            DataArr(0) = Workbooks(FileName).Worksheets(1).Range("E4").Value: DataArr(1) = Workbooks(FileName).Worksheets(1).Range("I6").Value
            DataArr(2) = Workbooks(FileName).Worksheets(1).Range("P6").Value: DataArr(3) = Workbooks(FileName).Worksheets(1).Range("G8").Value
            DataArr(4) = Workbooks(FileName).Worksheets(1).Range("H23").Value: DataArr(5) = Workbooks(FileName).Worksheets(1).Range("D31").Value
            DataArr(6) = Workbooks(FileName).Worksheets(1).Range("K36").Value: DataArr(7) = Workbooks(FileName).Worksheets(1).Range("P36").Value
            DataArr(8) = Workbooks(FileName).Worksheets(1).Range("K37").Value: DataArr(9) = Workbooks(FileName).Worksheets(1).Range("P37").Value
            DataArr(10) = Workbooks(FileName).Worksheets(1).Range("U35").Value: DataArr(11) = Workbooks(FileName).Worksheets(1).Range("J41").Value
            DataArr(12) = Workbooks(FileName).Worksheets(1).Range("J45").Value: DataArr(13) = Workbooks(FileName).Worksheets(1).Range("D64").Value
            DataArr(14) = Workbooks(FileName).Worksheets(1).Range("X171").Value: DataArr(15) = Workbooks(FileName).Worksheets(1).Range("P45").Value
            DataArr(16) = Workbooks(FileName).Worksheets(1).Range("AB70").Value: DataArr(17) = Workbooks(FileName).Worksheets(1).Range("H68").Value
            DataArr(18) = Workbooks(FileName).Worksheets(1).Range("H69").Value
          
            For i = 0 To UBound(DataArr)
                    Workbooks(strFileTarget).Worksheets(1).Cells(lastRow + 1, i + 1).Value = "'" & Trim(DataArr(i))
            Next

            Workbooks(FileName).Close SaveChanges:=False

          
        End If
      
        FileName = Dir
    Loop

Else
    MsgBox folder & "Specified Folder Not Found", vbInformation, "Not Found!"
End If
MsgBox ("Well Done!")
Application.ScreenUpdating = True
End Sub

 

[881516]

e edit lại một chút nhé

 

[881516]

mọi ng giúp e với ạ

 

[vanthinh3101]

mọi ng giúp e với ạ

Bạn gửi File tổng hợp và File thành phần lên nhé!
Dữ liệu thì chỉ cần dữ liệu giả định nhưng Template thì phải chuẩn.
Còn nếu bạn rành về code thì bạn có thể dùng đoạn code này để chọn file để tổng hợp:

With Application.FileDialog(msoFileDialogFilePicker)
   .AllowMultiSelect = True
   .Filters.Add "Microsoft Excel Files", "*.xls*", 1
     If Not .Show = -1 Then
          MsgBox "Ban chua chon File", vbCritical, "GPE"
          Exit Sub
     End If
    For Each Item In .SelectedItems
        'Các thủ tục theo yêu cầu '
  
    Next Item
End With

 

[881516]

Bạn gửi File tổng hợp và File thành phần lên nhé!
Dữ liệu thì chỉ cần dữ liệu giả định nhưng Template thì phải chuẩn.
Còn nếu bạn rành về code thì bạn có thể dùng đoạn code này để chọn file để tổng hợp:

With Application.FileDialog(msoFileDialogFilePicker)
   .AllowMultiSelect = True
   .Filters.Add "Microsoft Excel Files", "*.xls*", 1
     If Not .Show = -1 Then
          MsgBox "Ban chua chon File", vbCritical, "GPE"
          Exit Sub
     End If
    For Each Item In .SelectedItems
        'Các thủ tục theo yêu cầu '

    Next Item
End With

đoạn code này mình cũng xin được từ 1 file macro khác, mình cũng thử ghép vào code của mình nhưng ko hiểu sao chạy bị lỗi, nó báo lỗi ngay phần
Sub test() và endsub luôn

 

[vanthinh3101]

đoạn code này mình cũng xin được từ 1 file macro khác, mình cũng thử ghép vào code của mình nhưng ko hiểu sao chạy bị lỗi, nó báo lỗi ngay phần
Sub test() và endsub luôn

Bạn mà nói thế này thì bó tay luôn rồi.
Tốt nhất là đưa dữ liệu giả định với Template chuẩn lên đây là có câu trả lời ngay thôi.

 

[881516]

Bạn mà nói thế này thì bó tay luôn rồi.
Tốt nhất là đưa dữ liệu giả định với Template chuẩn lên đây là có câu trả lời ngay thôi.

file này của mình đang chạy nhé
file test là file chứa macro, file TKHQ là file cần lấy dữ liệu, (file này sẽ đặt tại thư mục có đường link tại ô A1, bạn tải về máy bạn sửa lại đường link giúp mình nhé)
Mong bạn giúp đỡ

 

[vanthinh3101]

file này của mình đang chạy nhé
file test là file chứa macro, file TKHQ là file cần lấy dữ liệu, (file này sẽ đặt tại thư mục có đường link tại ô A1, bạn tải về máy bạn sửa lại đường link giúp mình nhé)
Mong bạn giúp đỡ

Bạn bổ sung thêm thông tin các cột của file Test sẽ lấy dữ liệu nào tương ứng ở file Tokhai nhé!

 

[881516]

Bạn bổ sung thêm thông tin các cột của file Test sẽ lấy dữ liệu nào tương ứng ở file Tokhai nhé!

ở trên file test, từng ô có ghi rõ lấy từ ô nào trên file TK, hoặc mở macro ra cũng có các dòng lệnh lấy dữ liệu ô nào ở file TK
Mình chỉ muốn thay đổi cách nhập liệu thôi thì phần đó có liên quan ko bạn

 DataArr(0) = Workbooks(FileName).Worksheets(1).Range("E4").Value: DataArr(1) = Workbooks(FileName).Worksheets(1).Range("I6").Value
            DataArr(2) = Workbooks(FileName).Worksheets(1).Range("P6").Value: DataArr(3) = Workbooks(FileName).Worksheets(1).Range("G8").Value
            DataArr(4) = Workbooks(FileName).Worksheets(1).Range("H23").Value: DataArr(5) = Workbooks(FileName).Worksheets(1).Range("D31").Value
            DataArr(6) = Workbooks(FileName).Worksheets(1).Range("K36").Value: DataArr(7) = Workbooks(FileName).Worksheets(1).Range("P36").Value
            DataArr(8) = Workbooks(FileName).Worksheets(1).Range("K37").Value: DataArr(9) = Workbooks(FileName).Worksheets(1).Range("P37").Value
            DataArr(10) = Workbooks(FileName).Worksheets(1).Range("U35").Value: DataArr(11) = Workbooks(FileName).Worksheets(1).Range("J41").Value
            DataArr(12) = Workbooks(FileName).Worksheets(1).Range("J45").Value: DataArr(13) = Workbooks(FileName).Worksheets(1).Range("D64").Value
            DataArr(14) = Workbooks(FileName).Worksheets(1).Range("X171").Value: DataArr(15) = Workbooks(FileName).Worksheets(1).Range("P45").Value
            DataArr(16) = Workbooks(FileName).Worksheets(1).Range("AB70").Value: DataArr(17) = Workbooks(FileName).Worksheets(1).Range("H68").Value
            DataArr(18) = Workbooks(FileName).Worksheets(1).Range("H69").Value

 

[VetMini]

Code luộm thuộm bỏ bố.

rgList = VBA.Array("E4", "I6", "p6", ...) ' thêm vào chỗ ... cho đủ 19 ô
Set srcData = Workbooks(FileName).Worksheets(1) ' sửa cái source này khi cần
For i = 0 to 18
DataArr(i) = srcData.Range(rgList(i)).Value
Next i

 

[vanthinh3101]

ở trên file test, từng ô có ghi rõ lấy từ ô nào trên file TK, hoặc mở macro ra cũng có các dòng lệnh lấy dữ liệu ô nào ở file TK
Mình chỉ muốn thay đổi cách nhập liệu thôi thì phần đó có liên quan ko bạn

 DataArr(0) = Workbooks(FileName).Worksheets(1).Range("E4").Value: DataArr(1) = Workbooks(FileName).Worksheets(1).Range("I6").Value
            DataArr(2) = Workbooks(FileName).Worksheets(1).Range("P6").Value: DataArr(3) = Workbooks(FileName).Worksheets(1).Range("G8").Value
            DataArr(4) = Workbooks(FileName).Worksheets(1).Range("H23").Value: DataArr(5) = Workbooks(FileName).Worksheets(1).Range("D31").Value
            DataArr(6) = Workbooks(FileName).Worksheets(1).Range("K36").Value: DataArr(7) = Workbooks(FileName).Worksheets(1).Range("P36").Value
            DataArr(8) = Workbooks(FileName).Worksheets(1).Range("K37").Value: DataArr(9) = Workbooks(FileName).Worksheets(1).Range("P37").Value
            DataArr(10) = Workbooks(FileName).Worksheets(1).Range("U35").Value: DataArr(11) = Workbooks(FileName).Worksheets(1).Range("J41").Value
            DataArr(12) = Workbooks(FileName).Worksheets(1).Range("J45").Value: DataArr(13) = Workbooks(FileName).Worksheets(1).Range("D64").Value
            DataArr(14) = Workbooks(FileName).Worksheets(1).Range("X171").Value: DataArr(15) = Workbooks(FileName).Worksheets(1).Range("P45").Value
            DataArr(16) = Workbooks(FileName).Worksheets(1).Range("AB70").Value: DataArr(17) = Workbooks(FileName).Worksheets(1).Range("H68").Value
            DataArr(18) = Workbooks(FileName).Worksheets(1).Range("H69").Value

Gửi lại bạn code, đã làm gọn code nhờ hướng dẫn của bác @VetMini tại bài #10.

Sub GPE()
    Dim FolderPath As String, FileName As String
    Dim Wb As Workbook, Master As Worksheet
    Dim selectedFiles As Variant, List As Variant
    Dim i As Integer, j As Long, lastRow As Integer
   
    Set Master = ThisWorkbook.Sheets("data")
    List = Array("E4", "I6", "P6", "G8", "H23", "D31", "K36", "P36", "K37", "P37", "U35", _
                "J41", "J45", "D64", "X171", "P45", "AB70", "H68", "H69")
    Application.ScreenUpdating = False
       
    FolderPath = Range("A1").Value & "\"        'Duong dan thu muc do tim
    ChDrive FolderPath
    ChDir FolderPath
   
    On Error GoTo Quit
    selectedFiles = Application.GetOpenFilename(filefilter:="Excel Files (*.xls*),*.xlsx*", MultiSelect:=True)
    For i = LBound(selectedFiles) To UBound(selectedFiles)
        FileName = selectedFiles(i)
        Set Wb = Workbooks.Open(FileName)
       
        lastRow = Master.Cells(Rows.Count, "A").End(xlUp).Row
       
        For j = 0 To UBound(List)
            Master.Cells(lastRow + 1, j + 1).Value = "'" & Trim(Wb.Worksheets(1).Range(List(j)).Value)
        Next j
        Wb.Close False
    Next i
    Application.ScreenUpdating = True
    MsgBox "Well Done!", vbInformation, "GPE"
    Exit Sub
Quit:
    MsgBox "No file selected", vbCritical, "GPE"
End Sub

Để thuận tiện sử dụng code này trên máy khác, bạn nên bỏ 3 dòng sau:

FolderPath = Range("A1").Value & "\"        'Duong dan thu muc do tim
ChDrive FolderPath
ChDir FolderPath

 

[881516]

cảm ơn cả nhà nhé. em chạy code ok rồi