Xin giúp em chỉnh code

Chia sẻ bởi:hands

★★★★★

‹ Nhờ anh chị hỗ trợ công thức... Tổng hợp kết quả theo tháng ›

Quảng cáo

Em có đoạn code copy. Khi em chạy Getdata thì dữ liệu copy qua bị thiếu.
Em gủi 2 file : File data & file tổng họp.
Mong các AC giúp dùm em , chỉnh code lại cho nó lấy hết dữ liệu dùm em .
Em xin cám ơn

Function GetData(ByVal FileName As String, ByVal SheetName As String, ByVal RangeAddress As String, _
            ByVal HasTitle As Boolean, ByVal UseTitle As Boolean)

Dim rsCon As Object, rsData As Object, cat As Object, tbl As Object
  Dim tmpArr, Arr()
  Dim szConnect As String, szSQL As String, tmp As String
  Dim lCount As Long, lR As Long, lC As Long, lVer As Long
  lVer = Val(Application.Version)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  Set cat = CreateObject("ADOX.Catalog")

If lVer < 12 Then
    szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 8.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  Else
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";" & _
                "Extended Properties=""Excel 12.0;HDR=" & IIf(HasTitle, "Yes", "No") & """;"
  End If
  If SheetName = "" Then
    Dim Dbs  As Object, db As Object
    Set Dbs = CreateObject("DAO.DBEngine." & IIf(lVer < 12, "36", "120"))
    Set db = Dbs.OpenDatabase(FileName, False, False, "Excel 8.0;")
    tmp = db.TableDefs(0).Name
    tmp = Replace(tmp, " ", "?")
    tmp = Replace(tmp, "'", " ")
    tmp = WorksheetFunction.Trim(tmp)
    tmp = Replace(tmp, " ", "'")
    tmp = Replace(tmp, "?", " ")
    SheetName = tmp
    db.Close
    Set Dbs = Nothing: Set db = Nothing
  End If
  If Right(SheetName, 1) <> "$" Then SheetName = SheetName & "$"
  rsCon.Open szConnect
  cat.ActiveConnection = rsCon

szSQL = "SELECT * FROM [" & SheetName & RangeAddress & "];"
  rsData.Open szSQL, rsCon, 0, 1, 1
  tmpArr = rsData.GetRows
  ReDim Arr(UBound(tmpArr, 2) - UseTitle, UBound(tmpArr, 1) + 1)
  If UseTitle Then
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(0, lC) = rsData.Fields(lC).Name
    Next
  End If
  For lR = LBound(tmpArr, 2) To UBound(tmpArr, 2)
    For lC = LBound(tmpArr, 1) To UBound(tmpArr, 1)
      Arr(lR - UseTitle, lC) = tmpArr(lC, lR)
    Next
  Next
  rsData.Close: Set rsData = Nothing
  rsCon.Close: Set rsCon = Nothing
  GetData = Arr
End Function

Option Explicit
Sub Main()
  Dim vFile, FileItem, aRes, Target As Range
  Dim FileName As String, SheetName As String, RangeAddress As String
  On Error Resume Next
  vFile = Application.GetOpenFilename("Excel File, *.xls; *.xlsx; *.xlsm", , , , True)
  If TypeName(vFile) = "Variant()" Then
    SheetName = "Sheet1": RangeAddress = "A2:L10000"
    For Each FileItem In vFile
      FileName = CStr(FileItem)
      If UCase(FileName) <> UCase(ThisWorkbook.FullName) Then
        aRes = GetData(FileName, SheetName, RangeAddress, False, False)
        If IsArray(aRes) Then
          Set Target = Sheet1.Range("A60000").End(xlUp).Offset(1)
          Target.Resize(UBound(aRes, 1) + 1, UBound(aRes, 2) + 1).Value = aRes
        End If
      End If
    Next
    MsgBox "Done!"
  End If
End Sub

Nếu chỉ copy từ 1 hoặc nhiều Sheet của 1 hoặc nhiều file khác (có cùng cấu trúc) thì bạn có thể tham khảo code sau. Code này của 1 tác giả nào đó trên diễn đàn mà tôi không nhớ )

Option Explicit

Sub COPY_SHEET_VAO_SHEET_KHAC()
    Dim fnameList As Variant         '  Tap hop cac file can lay du lieu
    Dim fnameCurFile As Variant      ' File duoc chon mo trong tap hop fnameList
    Dim wbInBook As Workbook       ' workbook duoc mo
    Dim wbOutBook As Workbook
    Dim Ws As Worksheet     ' Worksheet duoc chon
    Dim sArr(), dArr(1 To 65000, 1 To 250), i As Long, j As Long, K As Long, cot As Long
    Dim tieude, dgcuoinguon As Long, dgcuoidich As Long
        Set wbInBook = ActiveWorkbook         ' Gán bien cho Workbook dýõc mõ
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

'=======KHOA MAN HINH=================
            Application.DisplayAlerts = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual

For Each fnameCurFile In fnameList   ' quet tung file trong tap hop
                Set wbOutBook = Workbooks.Open(FileName:=fnameCurFile)          'mo file
        For Each Ws In wbOutBook.Sheets
                If Ws.[A1] <> "" Then
                      dgcuoinguon = Ws.[A100000].End(xlUp).Row
                      dgcuoidich = wbInBook.Sheets("Sheet1").[A100000].End(xlUp).Row
                      cot = Ws.[IV1].End(xlToLeft).Column       'ðem so cot cua du lieu
                    If tieude = 0 Then
                          Ws.Range(Ws.[A1], Ws.[A65000].End(xlUp)).Resize(, cot + 1).Copy      wbInBook.Sheets("Sheet1").Range("A" & dgcuoidich + 1)
                    Else
                          Ws.Range(Ws.[A2], Ws.[A65000].End(xlUp)).Resize(, cot + 1).Copy wbInBook.Sheets("Sheet1").Range("A" & dgcuoidich + 1)
                    End If
                        tieude = 1
                End If
        Next Ws
   wbOutBook.Close SaveChanges:=False
Next fnameCurFile

Application.DisplayAlerts = True
            Application.ScreenUpdating = True
        MsgBox " THÀNH CÔNG"
End Sub
Với giả định File nguồn ( file Data. xlsx  )có 2 sheet  (có dữ liệu ).
nhấn mặt cười để được kết quả.

Dạ code này . Nếu em muốn lấy số cột cần muốn có được không ạ.

Nếu muốn lấy số cột ví dụ: dữ liệu có 10 cột ta chỉ cần lấy đến 7 cột thôi. Thì thay dòng cot = Ws..End(xlToLeft).Column thành cot =7. Trường hợp các cột cần lấy rời rạc, không liền kề liên tiếp, thì phải dùng mảng và chạy vòng lặp For i =1 to Ubound(arr)
For j= 1 to Ubound(arr,2) (với Arr là mảng nguồn.(Arr=Vùng dữ liệu của sheet cần lấy).value2.
Tôi chỉ đoán là thế thôi chứ chưa thử. do file đã xóa. Bạn tự sửa và test lại.