Copy dữ liệu từ nhiều file vào 1 file

[vudinhgiao]

Em học mót được đoạn code như trong file đính kèm để copy dữ liệu từ nhiều file vào 1 file. Cụ thể là copy dữ liệu từ các sheet có tên "EWF" trong tất cả các file được chọn vào 1 file mới (file mới được tạo ra có tên "Kết quả" được lưu cùng thư mục chứa file này. Các bác giúp em bổ sung code để khi copy giữ nguyên được định dạng và chỉ lấy giá trị, loại bỏ công thức trong sheet "EWF". Vùng A5:Q5 là vùng Tiêu đề của Vùng dữ liệu muốn copy ạ. em cảm ơn ạ

 

[vudinhgiao]

Các thầy rảnh xem và giúp em chút ạ

 

[khieukienag]

Tôi cũng học được code nầy. Cũng mong muốn có tiện ích như bạn. Nhưng không ai giúp thì mình tự Format bằng tay vậy.

 

[HieuCD]

Em học mót được đoạn code như trong file đính kèm để copy dữ liệu từ nhiều file vào 1 file. Cụ thể là copy dữ liệu từ các sheet có tên "EWF" trong tất cả các file được chọn vào 1 file mới (file mới được tạo ra có tên "Kết quả" được lưu cùng thư mục chứa file này. Các bác giúp em bổ sung code để khi copy giữ nguyên được định dạng và chỉ lấy giá trị, loại bỏ công thức trong sheet "EWF". Vùng A5:Q5 là vùng Tiêu đề của Vùng dữ liệu muốn copy ạ. em cảm ơn ạ

Thử code (chưa kiểm tra)

Sub Copydulieu()
  Dim shOutput As Worksheet, wbInput As Workbook
  Dim selectfiles As Variant
  Dim iFileNum, isheetNum, i As Integer
  Dim ilastRowInput, ilastRowOutput As Long
  Dim tieude As Boolean, RngAddress As String, Rng As Range
    
    RngAddress = ThisWorkbook.Sheets(1).Cells(7, 4).Value
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    'TAO MOT FILE LUU DATA
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Ket qua" & ".xlsx"
    Set shOutput = ActiveWorkbook.Sheets(1)
    'Goi phuwowng thuc mo nhieu file
    selectfiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*.xlsx", MultiSelect:=True)
    For iFileNum = 1 To UBound(selectfiles)
      Set wbInput = Workbooks.Open(selectfiles(iFileNum))
      With wbInput.Sheets("EWF")
        If .Range(RngAddress) <> "" Then
          'Xac dinh dong cuoi cung, de copy du lieu tiep theo
          ilastRowInput = .Range(Mid(RngAddress, 1, 1) & Rows.Count).End(xlUp).Row
          'Copy vung tieu de
          If tieude = False Then
            ilastRowOutput = shOutput.Range(Mid(RngAddress, 1, 1) & Rows.Count).End(xlUp).Row
            .Range(RngAddress).Copy Destination:=shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1)
            tieude = True
          End If
          ilastRowOutput = shOutput.Range(Mid(RngAddress, 1, 1) & Rows.Count).End(xlUp).Row
          Set Rng = .Range(Mid(Range(RngAddress).Offset(1).Address(0, 0), 1, 4) & ilastRowInput)
          Rng.Copy Destination:=shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1)
          shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1).Resize(Rng.Rows.Count, Rng.Columns.Count).Value = _
              shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1).Resize(Rng.Rows.Count, Rng.Columns.Count).Value
        End If
      End With
      wbInput.Close
    Next
    MsgBox "DA COPY XONG"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[vudinhgiao]

Thử code (chưa kiểm tra)

Sub Copydulieu()
  Dim shOutput As Worksheet, wbInput As Workbook
  Dim selectfiles As Variant
  Dim iFileNum, isheetNum, i As Integer
  Dim ilastRowInput, ilastRowOutput As Long
  Dim tieude As Boolean, RngAddress As String, Rng As Range
   
    RngAddress = ThisWorkbook.Sheets(1).Cells(7, 4).Value
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    'TAO MOT FILE LUU DATA
    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Ket qua" & ".xlsx"
    Set shOutput = ActiveWorkbook.Sheets(1)
    'Goi phuwowng thuc mo nhieu file
    selectfiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*.xlsx", MultiSelect:=True)
    For iFileNum = 1 To UBound(selectfiles)
      Set wbInput = Workbooks.Open(selectfiles(iFileNum))
      With wbInput.Sheets("EWF")
        If .Range(RngAddress) <> "" Then
          'Xac dinh dong cuoi cung, de copy du lieu tiep theo
          ilastRowInput = .Range(Mid(RngAddress, 1, 1) & Rows.Count).End(xlUp).Row
          'Copy vung tieu de
          If tieude = False Then
            ilastRowOutput = shOutput.Range(Mid(RngAddress, 1, 1) & Rows.Count).End(xlUp).Row
            .Range(RngAddress).Copy Destination:=shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1)
            tieude = True
          End If
          ilastRowOutput = shOutput.Range(Mid(RngAddress, 1, 1) & Rows.Count).End(xlUp).Row
          Set Rng = .Range(Mid(Range(RngAddress).Offset(1).Address(0, 0), 1, 4) & ilastRowInput)
          Rng.Copy Destination:=shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1)
          shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1).Resize(Rng.Rows.Count, Rng.Columns.Count).Value = _
              shOutput.Range(Mid(RngAddress, 1, 1) & ilastRowOutput + 1).Resize(Rng.Rows.Count, Rng.Columns.Count).Value
        End If
      End With
      wbInput.Close
    Next
    MsgBox "DA COPY XONG"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Code báo lỗi tại dòng lệnh: If .Range(RngAddress) <> "" Then
Bác sửa giúp được không ạ

 

[HieuCD]

Code báo lỗi tại dòng lệnh: If .Range(RngAddress) <> "" Then
Bác sửa giúp được không ạ

Chỉnh lại
If .Range(mid(RngAddress,1,2)) <> "" Then

 

[vudinhgiao]

Chỉnh lại
If .Range(mid(RngAddress,1,2)) <> "" Then

Phiền thầy quá ạ. Code của thầy chạy ok rồi nhưng mắc cái là giá trị của nó không xác định thầy ạ

 

[HieuCD]

Phiền thầy quá ạ. Code của thầy chạy ok rồi nhưng mắc cái là giá trị của nó không xác định thầy ạ

"giá trị của nó không xác định"? Nói rỏ hơn, Gởi file cần lấy dữ liệu và các tình huống cụ thể sẽ có cách xử lý sát thực tế

 

[vudinhgiao]

Phiền thầy quá ạ. Code của thầy chạy ok rồi nhưng mắc cái là giá trị của nó không xác định thầy ạ

Dạ thầy, em gửi cả mẫu thầy xem giúp ạ

"giá trị của nó không xác định"? Nói rỏ hơn, Gởi file cần lấy dữ liệu và các tình huống cụ thể sẽ có cách xử lý sát thực tế

Dạ thầy, em gửi file mẫu thầy xem giúp ạ

 

[HieuCD]

Dạ thầy, em gửi cả mẫu thầy xem giúp ạ

Dạ thầy, em gửi file mẫu thầy xem giúp ạ

Chỉnh code

Sub Copydulieu2()
  Dim shOutput As Worksheet, wbInput As Workbook
  Dim selectfiles As Variant
  Dim iFileNum&, isheetNum&, i&, fRow&, fCol&, sCol&
  Dim sRowInput&, ilastRowOutput&
  Dim tieude As Boolean, Rng As Range
 
    With ThisWorkbook.Sheets(1)
      Set Rng = .Range(.Range("D7").Value)
      fRow = Rng.Row:    fCol = Rng.Column
      sCol = Rng.Columns.Count
    End With
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Workbooks.Add 'TAO MOT FILE LUU DATA
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Ket qua" & ".xlsx"
    Set shOutput = ActiveWorkbook.Sheets(1)
    'Goi phuwowng thuc mo nhieu file
    selectfiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*.xlsx", MultiSelect:=True)
    For iFileNum = 1 To UBound(selectfiles)
      Set wbInput = Workbooks.Open(selectfiles(iFileNum))
      With wbInput.Sheets("EWF")
        If .Cells(fRow, fCol) <> "" Then
          ilastRowOutput = shOutput.Cells(Rows.Count, fCol).End(xlUp).Row + 1 'Xac dinh dong Past copy
          If tieude = False Then 'Copy vung tieu de            
            .Cells(fRow, fCol).Resize(2, sCol).Copy Destination:=shOutput.Cells(ilastRowOutput, fCol)
            ilastRowOutput = ilastRowOutput + 1
            tieude = True
          End If
          sRowInput = .Cells(Rows.Count, fCol).End(xlUp).Row - fRow + 1 'Xac dinh so dong, de copy du lieu
          shOutput.Cells(ilastRowOutput, fCol).Resize(sRowInput, sCol).Value = .Cells(fRow + 1, fCol).Resize(sRowInput, sCol).Value
        End If
      End With
      wbInput.Close
    Next
   
    Set Rng = shOutput.UsedRange.Offset(1).Resize(shOutput.UsedRange.Rows.Count - 1)
    Rng(1, 1).Resize(, sCol).Copy
    Rng.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    MsgBox "DA COPY XONG"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[vudinhgiao]

Chỉnh code

Sub Copydulieu2()
  Dim shOutput As Worksheet, wbInput As Workbook
  Dim selectfiles As Variant
  Dim iFileNum&, isheetNum&, i&, fRow&, fCol&, sCol&
  Dim sRowInput&, ilastRowOutput&
  Dim tieude As Boolean, Rng As Range

    With ThisWorkbook.Sheets(1)
      Set Rng = .Range(.Range("D7").Value)
      fRow = Rng.Row:    fCol = Rng.Column
      sCol = Rng.Columns.Count
    End With
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
  
    Workbooks.Add 'TAO MOT FILE LUU DATA
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "Ket qua" & ".xlsx"
    Set shOutput = ActiveWorkbook.Sheets(1)
    'Goi phuwowng thuc mo nhieu file
    selectfiles = Application.GetOpenFilename(Filefilter:="Excel File (*.xls*),*.xlsx", MultiSelect:=True)
    For iFileNum = 1 To UBound(selectfiles)
      Set wbInput = Workbooks.Open(selectfiles(iFileNum))
      With wbInput.Sheets("EWF")
        If .Cells(fRow, fCol) <> "" Then
          ilastRowOutput = shOutput.Cells(Rows.Count, fCol).End(xlUp).Row + 1 'Xac dinh dong Past copy
          If tieude = False Then 'Copy vung tieu de           
            .Cells(fRow, fCol).Resize(2, sCol).Copy Destination:=shOutput.Cells(ilastRowOutput, fCol)
            ilastRowOutput = ilastRowOutput + 1
            tieude = True
          End If
          sRowInput = .Cells(Rows.Count, fCol).End(xlUp).Row - fRow + 1 'Xac dinh so dong, de copy du lieu
          shOutput.Cells(ilastRowOutput, fCol).Resize(sRowInput, sCol).Value = .Cells(fRow + 1, fCol).Resize(sRowInput, sCol).Value
        End If
      End With
      wbInput.Close
    Next
  
    Set Rng = shOutput.UsedRange.Offset(1).Resize(shOutput.UsedRange.Rows.Count - 1)
    Rng(1, 1).Resize(, sCol).Copy
    Rng.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    MsgBox "DA COPY XONG"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Đã được như ý rồi ạ. Chân thành cảm ơn Thầy, Chúc thầy kỳ nghỉ lễ vui vẻ !