Gộp nhiều file excel vào một file với cấu trúc giống nhau thêm điều kiện gắn (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
V

vnlife2000

Thành viên chính thức
Tham gia
3/4/07
Bài viết
71
Được thích
0
Mình đã xem các bài viết về gộp nhiều file vào một file trên GPE nhưng vấn đề của mình khác ở những bài đã đăng là trên mỗi file có những dòng cố định phải lấy từ vị trí đó gắn vào đúng vị trí trong file tổng hợp. Nhờ các bạn giúp mình. Cảm ơn các bạn.
https://drive.google.com/file/d/0B90JC-QUiXE6ZHIyaFVZVkZncDg/view?usp=sharing
 
Lần chỉnh sửa cuối:
Chào bạn Hiếu, khi mình chạy code thì báo lỗi như hình, khi debug thì tô vàng tại dòng: rsCon.Open szConnect . Nhưng bấm End thì vẫn chạy ra kết quả. và bạn giúp mình chỗ chú thích đoạn nào lấy dữ liệu từ các file con, vì số lượng các dòng của file con sẽ tăng lên theo các dòng màu trắng.
 

File đính kèm

  • er1.jpg
    er1.jpg
    28.9 KB · Đọc: 59
Lần chỉnh sửa cuối:
vnlife2000 đã viết:
Chào bạn Hiếu, khi mình chạy code thì báo lỗi như hình, khi debug thì tô vàng tại dòng: rsCon.Open szConnect . Nhưng bấm End thì vẫn chạy ra kết quả. và bạn giúp mình chỗ chú thích đoạn nào lấy dữ liệu từ các file con, vì số lượng các dòng của file con sẽ tăng lên theo các dòng màu trắng.
Nhấp chuột vào đây để mở rộng...
bị lổi có thể bạn chạy thử và ngưng ngang, bạn đóng tập tin và mở lại sau đó chạy code xem còn bị không?
bạn chú ý chổ màu đỏ
Mã: 
Sub TongHop()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim Darr(), Arr, Ro, R, i As Integer, j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer
[COLOR=#ff0000]  SoDong = 2[/COLOR]
  ReDim Darr(0 To SoDong - 1, 0 To 45)
  Ro = Array(0, 7, 11, 15, 22, 27)
[COLOR=#ff0000]  '0,7,11 ...là dòng dau cua tung vùng láy du lieu, dem tu so 0 cua dong dau tien(dong 13 cua sheet là: 0)[/COLOR]
  R = Array(13, 38, 59, 80, 104, 126)
[COLOR=#ff0000]  '13,38...là dòng dau cua tung vùng tra ket qua[/COLOR]
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, len(ThisWorkbook.Name)) <> ThisWorkbook.Name Then
      SourceFile = ObjFile:   SourceSheet = "Sheet1":    SourceRange = "B13:AU41"
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
      Set rsCon = CreateObject("ADODB.Connection")
      Set rsData = CreateObject("ADODB.Recordset")
      rsCon.Open szConnect
      rsData.Open szSQL, rsCon, 3, 1
      If Not rsData.EOF Then Arr = rsData.GetRows()
      rsData.Close:       Set rsData = Nothing
      rsCon.Close:        Set rsCon = Nothing
      n = n + 1
      For k = 0 To 5
        For j = 0 To 45
          For S = 0 To SoDong - 1
            Darr(S, j) = Arr(j, Ro(k) + S)
          Next S
          'Darr(0, j) = Arr(j, Ro(k))
          'Darr(1, j) = Arr(j, Ro(k) + 1)
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, 46) = Darr
      Next k
    End If
  Next ObjFile
    Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Bạn Hiếu xem giúp mình tăng số dòng của file con và file tổng hợp lên thành 1146 nhưng khi chạy báo lỗi subscript out of range tại dòng Darr(S, j) = Arr(j, Ro(k) + S). Bạn giúp mình code với.
Mã: 
Sub TongHop2()  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim Darr(), Arr, Ro, R, i As Integer, j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer
  SoDong = 2
  ReDim Darr(0 To SoDong - 1, 0 To 1146)
  'Ro = Array(0, 7, 11, 15, 22, 27)
  '0,7,11 ...là dòng dau cua tung vùng láy du lieu, dem tu so 0 cua dong dau tien(dong 13 cua sheet là: 0)
   Ro = Array(0, 120, 423, 547, 574, 591, 608, 627, 639, 656, 675, 682, 689, 700, 1020, 1028, 1040, 1101, 1114, 1125, 1129, 1133)
   R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)
  'R = Array(13, 38, 59, 80, 104, 126)
  '13,38...là dòng dau cua tung vùng tra ket qua
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name Then
      SourceFile = ObjFile:   SourceSheet = "Sheet1":    SourceRange = "B13:AU1143"
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
      Set rsCon = CreateObject("ADODB.Connection")
      Set rsData = CreateObject("ADODB.Recordset")
      rsCon.Open szConnect
      rsData.Open szSQL, rsCon, 3, 1
      If Not rsData.EOF Then Arr = rsData.GetRows()
      rsData.Close:       Set rsData = Nothing
      rsCon.Close:        Set rsCon = Nothing
      n = n + 1
      For k = 0 To 5
        For j = 0 To 1146
          For S = 0 To SoDong - 1
            Darr(S, j) = Arr(j, Ro(k) + S)
          Next S
          'Darr(0, j) = Arr(j, Ro(k))
          'Darr(1, j) = Arr(j, Ro(k) + 1)
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, 1147) = Darr
      Next k
    End If
  Next ObjFile
    Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
    Application.ScreenUpdating = True
End Sub
HieuCD đã viết:
bị lổi có thể bạn chạy thử và ngưng ngang, bạn đóng tập tin và mở lại sau đó chạy code xem còn bị không?
bạn chú ý chổ màu đỏ
Mã: 
Sub TongHop()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim Darr(), Arr, Ro, R, i As Integer, j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer
[COLOR=#ff0000]  SoDong = 2[/COLOR]
  ReDim Darr(0 To SoDong - 1, 0 To 45)
  Ro = Array(0, 7, 11, 15, 22, 27)
[COLOR=#ff0000]  '0,7,11 ...là dòng dau cua tung vùng láy du lieu, dem tu so 0 cua dong dau tien(dong 13 cua sheet là: 0)[/COLOR]
  R = Array(13, 38, 59, 80, 104, 126)
[COLOR=#ff0000]  '13,38...là dòng dau cua tung vùng tra ket qua[/COLOR]
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, len(ThisWorkbook.Name)) <> ThisWorkbook.Name Then
      SourceFile = ObjFile:   SourceSheet = "Sheet1":    SourceRange = "B13:AU41"
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
      Set rsCon = CreateObject("ADODB.Connection")
      Set rsData = CreateObject("ADODB.Recordset")
      rsCon.Open szConnect
      rsData.Open szSQL, rsCon, 3, 1
      If Not rsData.EOF Then Arr = rsData.GetRows()
      rsData.Close:       Set rsData = Nothing
      rsCon.Close:        Set rsCon = Nothing
      n = n + 1
      For k = 0 To 5
        For j = 0 To 45
          For S = 0 To SoDong - 1
            Darr(S, j) = Arr(j, Ro(k) + S)
          Next S
          'Darr(0, j) = Arr(j, Ro(k))
          'Darr(1, j) = Arr(j, Ro(k) + 1)
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, 46) = Darr
      Next k
    End If
  Next ObjFile
    Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Bạn Hiếu xem giúp mình tăng số dòng của file con và file tổng hợp lên thành 1146 nhưng khi chạy báo lỗi subscript out of range tại dòng Darr(S, j) = Arr(j, Ro(k) + S). Bạn giúp mình code với
Nhấp chuột vào đây để mở rộng...
Lỗi là đúng vì bạn không đọc ah, phải nhập vào dòng đỏ này, không phải nhập thay số 45
SoDong = 2
 
vnlife2000 đã viết:
Bạn Hiếu xem giúp mình tăng số dòng của file con và file tổng hợp lên thành 1146 nhưng khi chạy báo lỗi subscript out of range tại dòng Darr(S, j) = Arr(j, Ro(k) + S). Bạn giúp mình code với.
Nhấp chuột vào đây để mở rộng...
không biết lý do gì mà code chỉ lấy được 1005 dòng, kể cả code của bạn trong file
đành chấp nhận chạy chậm vậy
Mã: 
Sub TongHop2()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim R, k As Integer, n As Integer, SoDong As Integer
  SoDong = 2
  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)
  '13,133...là dòng dau cua tung vùng lay du lieu, va tra ket qua
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name Then
      n = n + 1
      SourceFile = ObjFile:   SourceSheet = "Sheet1"
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      For k = 0 To UBound(R)
        SourceRange = "B" & R(k) & ":AU" & R(k) + SoDong - 1
        szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
        rsCon.Open szConnect
        rsData.Open szSQL, rsCon, 3, 1
        If Not rsData.EOF Then
          ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).CopyFromRecordset rsData
        End If
        rsData.Close:        rsCon.Close
      Next k
    End If
  Next ObjFile
  Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
  Set rsData = Nothing: Set rsCon = Nothing
  Application.ScreenUpdating = True
End Sub
 
Bạn Hiếu code đỡ 1005 dòng cũng đc bạn. chứ này chậm treo máy luôn bạn
HieuCD đã viết:
không biết lý do gì mà code chỉ lấy được 1005 dòng, kể cả code của bạn trong file
đành chấp nhận chạy chậm vậy
Mã: 
Sub TongHop2()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim R, k As Integer, n As Integer, SoDong As Integer
  SoDong = 2
  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)
  '13,133...là dòng dau cua tung vùng lay du lieu, va tra ket qua
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name Then
      n = n + 1
      SourceFile = ObjFile:   SourceSheet = "Sheet1"
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      For k = 0 To UBound(R)
        SourceRange = "B" & R(k) & ":AU" & R(k) + SoDong - 1
        szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
        rsCon.Open szConnect
        rsData.Open szSQL, rsCon, 3, 1
        If Not rsData.EOF Then
          ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).CopyFromRecordset rsData
        End If
        rsData.Close:        rsCon.Close
      Next k
    End If
  Next ObjFile
  Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
  Set rsData = Nothing: Set rsCon = Nothing
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Bạn Hiếu ơi,code giúp mình 1005 dòng cũng được, và cả file con và file tổng hợp đều có cấu trúc như nhau 1005 dòng, nhưng khi lấy dữ liệu từ file con thì chỉ lấy từ các vị trí không tô màu xanh giống như code bạn đã làm đối với 20 dòng lấy dữ liệu và gắng vào đúng vùng, không làm mất cấu trúc của file tổng hợp. Cảm ơn bạn.
HieuCD đã viết:
không biết lý do gì mà code chỉ lấy được 1005 dòng, kể cả code của bạn trong file
đành chấp nhận chạy chậm vậy
Mã: 
Sub TongHop2()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim R, k As Integer, n As Integer, SoDong As Integer
  SoDong = 2
  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)
  '13,133...là dòng dau cua tung vùng lay du lieu, va tra ket qua
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  Set rsCon = CreateObject("ADODB.Connection")
  Set rsData = CreateObject("ADODB.Recordset")
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name Then
      n = n + 1
      SourceFile = ObjFile:   SourceSheet = "Sheet1"
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      For k = 0 To UBound(R)
        SourceRange = "B" & R(k) & ":AU" & R(k) + SoDong - 1
        szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
        rsCon.Open szConnect
        rsData.Open szSQL, rsCon, 3, 1
        If Not rsData.EOF Then
          ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).CopyFromRecordset rsData
        End If
        rsData.Close:        rsCon.Close
      Next k
    End If
  Next ObjFile
  Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
  Set rsData = Nothing: Set rsCon = Nothing
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
vnlife2000 đã viết:
Bạn Hiếu ơi,code giúp mình 1005 dòng cũng được, và cả file con và file tổng hợp đều có cấu trúc như nhau 1005 dòng, nhưng khi lấy dữ liệu từ file con thì chỉ lấy từ các vị trí không tô màu xanh giống như code bạn đã làm đối với 20 dòng lấy dữ liệu và gắng vào đúng vùng, không làm mất cấu trúc của file tổng hợp. Cảm ơn bạn.
Nhấp chuột vào đây để mở rộng...
bạn chỉnh lại 2 mảng cho phù hợp
Ro = Array(0, 120, 423, 547, 574, 591, 608, 627, 639, 656, 675, 682, 689, 700, 1020, 1028, 1040, 1101, 1114, 1125, 1129, 1133)
R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)
 
giống như code lúc nãy mình gửi bạn, chạy báo lỗi bạn Hiếu ơi.
HieuCD đã viết:
bạn chỉnh lại 2 mảng cho phù hợp
Ro = Array(0, 120, 423, 547, 574, 591, 608, 627, 639, 656, 675, 682, 689, 700, 1020, 1028, 1040, 1101, 1114, 1125, 1129, 1133)
R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)
Nhấp chuột vào đây để mở rộng...
 
bạn chạy thử code, nếu bị lổi thì rà vào chổ KiemTraSoDong xem số dòng lấy được là bao nhiêu, và chỉnh lại 2 mảng màu đỏ cho phù hợp
kiểm tra lại vùng lấy dữ liệu
Mã: 
Sub TongHop3()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim Darr(), Arr, Ro, R, i As Integer, j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer, Cot As Integer
[COLOR=#0000cd]  SoDong = 2[/COLOR]
[COLOR=#ff0000]  Ro = Array(0, 120, 423, 547, 574, 591, 608, 627, 639, 656, 675, 682, 689, 700, 1020, 1028, 1040, 1101, 1114, 1125, 1129, 1133)[/COLOR]
[COLOR=#ff0000]  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, len([COLOR=#000000]ThisWorkbook.Name)[/COLOR]) <> ThisWorkbook.Name Then
      SourceFile = ObjFile:   SourceSheet = "Sheet1":    SourceRange = [COLOR=#ff0000]"B13:AU1150"[/COLOR]
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
      Set rsCon = CreateObject("ADODB.Connection")
      Set rsData = CreateObject("ADODB.Recordset")
      rsCon.Open szConnect
      rsData.Open szSQL, rsCon, 3, 1
      If Not rsData.EOF Then Arr = rsData.GetRows()
      rsData.Close:       Set rsData = Nothing
      rsCon.Close:        Set rsCon = Nothing


      [COLOR=#ff0000]KiemTraSoDong[/COLOR] = UBound(Arr, 2)  'chi dùng de kiem tra so dong lay du lieu
      n = n + 1
      Cot = UBound(Arr)
      ReDim Darr(0 To SoDong - 1, 0 To Cot)
      For k = 0 To UBound(R)
        For j = 0 To Cot
          For S = 0 To SoDong - 1
            Darr(S, j) = Arr(j, Ro(k) + S)
          Next S
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, Cot + 1) = Darr
      Next k
    End If
  Next ObjFile
    Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
    Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
code Kiemtrasodong lúc đầu báo 1137 sau đó mình điều chỉnh lại 2 mảng màu đỏ phù hợp lại như dưới, khi bấm chạy báo lỗi và check lỗi kiemtrasodong giờ báo số khác 1124. Và hình như nó chỉ chép qua được 2 dòng của sheet con qua sheet tổng hợp theo vùng thôi bạn Hiếu ơi.
Ro = Array(0, 120, 423, 547, 574, 591, 608, 627, 639, 656, 675, 682, 689, 700, 1020, 1028, 1040, 1101, 1108, 1116, 1120, 1124)
R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1121, 1129, 1133, 1137)
Nhấp chuột vào đây để mở rộng...
HieuCD đã viết:
bạn chạy thử code, nếu bị lổi thì rà vào chổ KiemTraSoDong xem số dòng lấy được là bao nhiêu, và chỉnh lại 2 mảng màu đỏ cho phù hợp
kiểm tra lại vùng lấy dữ liệu
Mã: 
Sub TongHop3()
  Dim objFSO As Object, objFolder As Object, ObjFile As Object, rsCon As Object, rsData As Object
  Dim szConnect, szSQL, SourceFile, SourceSheet, SourceRange As String
  Dim Darr(), Arr, Ro, R, i As Integer, j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer, Cot As Integer
[COLOR=#0000cd]  SoDong = 2[/COLOR]
[COLOR=#ff0000]  Ro = Array(0, 120, 423, 547, 574, 591, 608, 627, 639, 656, 675, 682, 689, 700, 1020, 1028, 1040, 1101, 1114, 1125, 1129, 1133)[/COLOR]
[COLOR=#ff0000]  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
  Application.ScreenUpdating = False
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In objFolder.Files
    If Right(ObjFile, len([COLOR=#000000]ThisWorkbook.Name)[/COLOR]) <> ThisWorkbook.Name Then
      SourceFile = ObjFile:   SourceSheet = "Sheet1":    SourceRange = [COLOR=#ff0000]"B13:AU1150"[/COLOR]
      If Application.Version < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & SourceFile & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
      Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & SourceFile & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
      End If
      szSQL = "SELECT * FROM [" & SourceSheet & "$" & SourceRange$ & "] "
      Set rsCon = CreateObject("ADODB.Connection")
      Set rsData = CreateObject("ADODB.Recordset")
      rsCon.Open szConnect
      rsData.Open szSQL, rsCon, 3, 1
      If Not rsData.EOF Then Arr = rsData.GetRows()
      rsData.Close:       Set rsData = Nothing
      rsCon.Close:        Set rsCon = Nothing


      [COLOR=#ff0000]KiemTraSoDong[/COLOR] = UBound(Arr, 2)  'chi dùng de kiem tra so dong lay du lieu
      n = n + 1
      Cot = UBound(Arr)
      ReDim Darr(0 To SoDong - 1, 0 To Cot)
      For k = 0 To UBound(R)
        For j = 0 To Cot
          For S = 0 To SoDong - 1
            Darr(S, j) = Arr(j, Ro(k) + S)
          Next S
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, Cot + 1) = Darr
      Next k
    End If
  Next ObjFile
    Set objFSO = Nothing: Set objFolder = Nothing: Set ObjFile = Nothing
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
dùng cách khác cho dể tính
Mã: 
Sub TongHop4()
  Dim WB As Workbook, Fso As Object, ObjFoder As Object, ObjFile As Object, Darr(), Arr(), Ro, R
  Dim j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer, Cot As Integer
  Application.ScreenUpdating = False
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
[COLOR=#ff0000]  SoDong = 2[/COLOR]
[COLOR=#ff0000]  Ro = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
[COLOR=#ff0000]  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set WB = Workbooks.Open(ObjFile)
      Arr = Range([COLOR=#ff0000]"B1:AU1150"[/COLOR]).Value
      WB.Close False
      n = n + 1
      Cot = UBound(Arr, 2)
      ReDim Darr(1 To SoDong, 1 To Cot)
      For k = 0 To UBound(R)
        For j = 1 To Cot
          For S = 1 To SoDong
            Darr(S, j) = Arr(Ro(k) + S - 1, j)
          Next S
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, Cot + 1) = Darr
      Next k
    End If
  Next
  Application.ScreenUpdating = True
End Sub
 
Chạy không báo lỗi nữa nhưng chép dữ liệu cũng chỉ có 2 dòng và nó làm mất đi các dòng cố định trong file tổng hợp.
HieuCD đã viết:
dùng cách khác cho dể tính
Mã: 
Sub TongHop4()
  Dim WB As Workbook, Fso As Object, ObjFoder As Object, ObjFile As Object, Darr(), Arr(), Ro, R
  Dim j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer, Cot As Integer
  Application.ScreenUpdating = False
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
[COLOR=#ff0000]  SoDong = 2[/COLOR]
[COLOR=#ff0000]  Ro = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
[COLOR=#ff0000]  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set WB = Workbooks.Open(ObjFile)
      Arr = Range([COLOR=#ff0000]"B1:AU1150"[/COLOR]).Value
      WB.Close False
      n = n + 1
      Cot = UBound(Arr, 2)
      ReDim Darr(1 To SoDong, 1 To Cot)
      For k = 0 To UBound(R)
        For j = 1 To Cot
          For S = 1 To SoDong
            Darr(S, j) = Arr(Ro(k) + S - 1, j)
          Next S
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, Cot + 1) = Darr
      Next k
    End If
  Next
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
Mình gửi lại bạn file 1146 dòng, bạn code giúp mình, các file con cũng tương tự file tổng hợp này. Cảm ơn bạn.
https://drive.google.com/open?id=0B90JC-QUiXE6VEFTNi1XODVqcXM
HieuCD đã viết:
dùng cách khác cho dể tính
Mã: 
Sub TongHop4()
  Dim WB As Workbook, Fso As Object, ObjFoder As Object, ObjFile As Object, Darr(), Arr(), Ro, R
  Dim j As Integer, k As Integer, n As Integer, SoDong As Integer, S As Integer, Cot As Integer
  Application.ScreenUpdating = False
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
[COLOR=#ff0000]  SoDong = 2[/COLOR]
[COLOR=#ff0000]  Ro = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
[COLOR=#ff0000]  R = Array(13, 133, 436, 560, 587, 604, 621, 640, 652, 669, 688, 695, 702, 713, 1033, 1041, 1053, 1114, 1127, 1138, 1142, 1146)[/COLOR]
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(ThisWorkbook.Name)) <> ThisWorkbook.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set WB = Workbooks.Open(ObjFile)
      Arr = Range([COLOR=#ff0000]"B1:AU1150"[/COLOR]).Value
      WB.Close False
      n = n + 1
      Cot = UBound(Arr, 2)
      ReDim Darr(1 To SoDong, 1 To Cot)
      For k = 0 To UBound(R)
        For j = 1 To Cot
          For S = 1 To SoDong
            Darr(S, j) = Arr(Ro(k) + S - 1, j)
          Next S
        Next j
        ThisWorkbook.Sheets("TONGHOP").Range("B" & R(k) + (n - 1) * SoDong).Resize(SoDong, Cot + 1) = Darr
      Next k
    End If
  Next
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
 
mỗi file chép vào 1 vùng mấy dòng?
 
sheet baocao của bạn có số dòng của từng vùng dữ liệu không giống nhau, khi chép vào sẽ làm mất vùng xanh là đúng rồi
bạn phải thiết kế lại sheet báo cáo, và qui định rỏ từng vùng mỗi file chép vào mấy dòng, và bao nhiêu file cần chép
 
vnlife2000 đã viết:
Mỗi một file có số dòng của từng vùng khác nhau, nhưng vẫn nằm trong giới hạn vùng của file con đó, và mỗi vùng của file con chỉ ghép vào file tổng hợp đúng bằng số dòng của vùng file con đó có.
Nhấp chuột vào đây để mở rộng...
để dể hình dung, bạn nhập tạm vào cột A của tất cả vùng: 1 là của file 1, 2 là của file 2 .... để mình biết cách lấy từng vùng và từng file như thế nào
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

G
Xin Code xóa Module. (1 người xem)
Trả lời
11
Đọc
451
GCQ
G
H
  • Question Question
Tô đậm tiêu đề cho cho các sheet (1 người xem)
Trả lời
4
Đọc
132
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
    • Thích
Trả lời
1
Đọc
884
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
87
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện (1 người xem)
Trả lời
5
Đọc
121
LePhatHuy
LePhatHuy
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản.
Trả lời
9
Đọc
197
duongbabao90
D
F
  • Question Question
Tự động Merge Mail bằng VBA (1 người xem)
Trả lời
7
Đọc
332
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang
Trả lời
10
Đọc
47K
pvkiem
P
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
395
tle2003
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
17
Đọc
499
VetMini
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
348
Đọc
31K
ongke0711
ongke0711
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
23
Đọc
768
nguyendang95
N
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
26
Đọc
2K
thuytrangbp28
T
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025
Trả lời
8
Đọc
217
bebo021999
B
N
Hàm tăng số đếm theo điều kiện
Trả lời
4
Đọc
129
bebo021999
B
M
Xin giúp đỡ làm công thức điều kiện
    • Yêu thích
Trả lời
3
Đọc
179
tayGa
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính
    • Thích
Trả lời
2
Đọc
266
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
5
Đọc
225
DeTong
D
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom