Giúp Code Copy data từ các sheet theo Form

  • Thread starter Thread starter letuvan
  • Ngày gửi Ngày gửi
Liên hệ QC
L

letuvan

Thành viên mới
Tham gia
31/12/11
Bài viết
18
Được thích
1
Nhờ các cao nhân chỉ giáo

E cần copy các dữ liệu từ các sheet 1 sheet 2, sheet 3 vào Sheet "Form"

Sheet "Form" đã cố định các cột dữ liệu cần copy từ các sheet 1,2,3. tên các tiêu đề cột các sheet 1,2,3 giống nhau nhưng sắp xếp thứ tự các cột khác nhau

Do data lớn mỗi sheet 30k dòng ( nhiều sheet) nên e dùng công thức rât nặng. Mong các bác chỉ giáo

E gửi kèm theo file đính kèm ạ

E cám ơn
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
letuvan đã viết:
Nhờ các cao nhân chỉ giáo

E cần copy các dữ liệu từ các sheet 1 sheet 2, sheet 3 vào Sheet "Form"

Sheet "Form" đã cố định các cột dữ liệu cần copy từ các sheet 1,2,3. tên các tiêu đề cột các sheet 1,2,3 giống nhau nhưng sắp xếp thứ tự các cột khác nhau

Do data lớn mỗi sheet 30k dòng ( nhiều sheet) nên e dùng công thức rât nặng. Mong các bác chỉ giáo

E gửi kèm theo file đính kèm ạ

E cám ơn
Nhấp chuột vào đây để mở rộng...
Không phải cao nhân được không bạn.
 
Upvote 0
Thiết kế các trang tính quá ư tùy tiện như vậy thì cao nhân sẽ chào thua; Chỉ các thấp nhân mới dám giúp bạn thôi. Mà giúp bạn là hại bạn về lâu dài đó; Chả tốt lành gì đâu!

Ngay đến 3 trang tính chứa dữ liệu (cần copy) cũng không giống nhau nữa thì chả mấy chốc CSDL của bạn thành đống phân chứ không thể thành đống rác đâu!

Thân ái!
 
Upvote 0
letuvan đã viết:
Nhờ các cao nhân chỉ giáo

E cần copy các dữ liệu từ các sheet 1 sheet 2, sheet 3 vào Sheet "Form"

Sheet "Form" đã cố định các cột dữ liệu cần copy từ các sheet 1,2,3. tên các tiêu đề cột các sheet 1,2,3 giống nhau nhưng sắp xếp thứ tự các cột khác nhau

Do data lớn mỗi sheet 30k dòng ( nhiều sheet) nên e dùng công thức rât nặng. Mong các bác chỉ giáo

E gửi kèm theo file đính kèm ạ

E cám ơn
Nhấp chuột vào đây để mở rộng...
Góp ý cho bạn.
Muốn làm cái gì đó đối với nhiều sheet thì hãy nghĩ ngay đến cấu trúc của nó phải giống nhau về tiêu đề cột và thứ tự các cột, nó có 2 cái lợi là dễ dàng gộp sheet, nếu phát hiện ra sai sót thì dễ dàng kiểm tra lại nó sai ở sheet nào.
 
Upvote 0
Cám ơn mn góp ý.
Do dữ liệu từ 1 nguồn độc lập nên mình ko thể can thiệp để yêu cầu họ xuất theo ý mình, vai trò của mình là check chéo trên database nhận được
Về thông tin mình cũng chỉ quan trọng 5-7 trường thông tin còn lại các cột chỉ để tham khảo khi cần

Mong nhận được góp ý và giúp đỡ của mn
Mình cám ơn
 
Upvote 0
letuvan đã viết:
Cám ơn mn góp ý.
Do dữ liệu từ 1 nguồn độc lập nên mình ko thể can thiệp để yêu cầu họ xuất theo ý mình, vai trò của mình là check chéo trên database nhận được
Về thông tin mình cũng chỉ quan trọng 5-7 trường thông tin còn lại các cột chỉ để tham khảo khi cần

Mong nhận được góp ý và giúp đỡ của mn
Mình cám ơn
Nhấp chuột vào đây để mở rộng...
Vậy bạn chỉ cần lấy Data kết quả thôi.cái tổng hợp chỉ cần 5 đến 7 trường thông tin thôi.
 
Upvote 0
be09 đã viết:
Góp ý cho bạn.
Muốn làm cái gì đó đối với nhiều sheet thì hãy nghĩ ngay đến cấu trúc của nó phải giống nhau về tiêu đề cột và thứ tự các cột, nó có 2 cái lợi là dễ dàng gộp sheet, nếu phát hiện ra sai sót thì dễ dàng kiểm tra lại nó sai ở sheet nào.
Nhấp chuột vào đây để mở rộng...
Theo kinh nghiệm của tôi thì đề xuất lãnh đạo ban hành 1 mẫu thống nhất gửi cho các bộ phận trực thuộc sử dụng.
Khi các đơn vị gửi File báo cáo về thì bỏ vào Folder và chỉ việc gộp File rồi sử dụng PivotTable là tổng hợp được kết quả cần báo cáo.
 
Upvote 0
snow25 đã viết:
Vậy bạn chỉ cần lấy Data kết quả thôi.cái tổng hợp chỉ cần 5 đến 7 trường thông tin thôi.
Nhấp chuột vào đây để mở rộng...
Thực tế đúng là báo cáo của mình chỉ cần 5-7 trường thông tin, nhưng mình mong muốn có thể dự phòng được các thông tin khi cần, để khi hỏi thì mình có thể xoay được ngay
Bài đã được tự động gộp:

be09 đã viết:
Theo kinh nghiệm của tôi thì đề xuất lãnh đạo ban hành 1 mẫu thống nhất gửi cho các bộ phận trực thuộc sử dụng.
Khi các đơn vị gửi File báo cáo về thì bỏ vào Folder và chỉ việc gộp File rồi sử dụng PivotTable là tổng hợp được kết quả cần báo cáo.
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn, do CTTV mình cũng chưa nắm quyền chi phối nên cũng khó trong trường hợp này, hơn nữa mình lại gộp từ nhiều CTTV khác nhau, việc này hiện tại chưa làm được
 
Upvote 0
letuvan đã viết:
Thực tế đúng là báo cáo của mình chỉ cần 5-7 trường thông tin, nhưng mình mong muốn có thể dự phòng được các thông tin khi cần, để khi hỏi thì mình có thể xoay được ngay.
Cám ơn bạn, do CTTV mình cũng chưa nắm quyền chi phối nên cũng khó trong trường hợp này, hơn nữa mình lại gộp từ nhiều CTTV khác nhau, việc này hiện tại chưa làm được
Nhấp chuột vào đây để mở rộng...
Vậy thì bạn chỉ còn cách tự sắp xếp tiêu đề các sheet cho giống nhau (là cách đơn giản nhất) rồi gộp sheet, sau đó copy sang sheet mới rồi xóa những cột không cần thiết hoặc có thể thực hiện ngay trong sheet TH.
 
Upvote 0
letuvan đã viết:
Bài đã được tự động gộp:

Có A/e nào giúp mình ko ạ
Nhấp chuột vào đây để mở rộng...
Đây bạn xem code nhé.
Mã: 
Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("TH")
         For i = 1 To 34
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    ReDim arr1(1 To 10000, 1 To 34)
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("C" & Rows.Count).End(xlUp).Row
           If lr > 6 Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
         End If
     End If
  Next
  With Sheets("TH")
   lr = .Range("A" & Rows.Count).End(xlUp).Row
   If lr > 1 Then .Range("A2:AH" & lr).ClearContents
    If a Then .Range("A2").Resize(a, 34).Value = arr1
  End With
End Sub
 

File đính kèm

Upvote 0
snow25 đã viết:
Đây bạn xem code nhé.
Mã: 
Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("TH")
         For i = 1 To 34
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    ReDim arr1(1 To 10000, 1 To 34)
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("C" & Rows.Count).End(xlUp).Row
           If lr > 6 Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
         End If
     End If
  Next
  With Sheets("TH")
   lr = .Range("A" & Rows.Count).End(xlUp).Row
   If lr > 1 Then .Range("A2:AH" & lr).ClearContents
    If a Then .Range("A2").Resize(a, 34).Value = arr1
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn nhiều nhé,
Mình muốn thêm cột trong form là "tên sheet" để kiểm soát số dòng dữ liệu các sheet khi copy được ko bạn, ngoài ra mình có rất nhiều sheet tên khác nhau và mỗi sheet số lượng dòng khá lớn, bạn xem giúp mình với nhé, mình gửi file đính kèm để bạn xem lỗi khi chạy nhé
 

File đính kèm

  • Untitled.png
    Untitled.png
    105.3 KB · Đọc: 5
Upvote 0
letuvan đã viết:
Cám ơn bạn nhiều nhé,
Mình muốn thêm cột trong form là "tên sheet" để kiểm soát số dòng dữ liệu các sheet khi copy được ko bạn, ngoài ra mình có rất nhiều sheet tên khác nhau và mỗi sheet số lượng dòng khá lớn, bạn xem giúp mình với nhé, mình gửi file đính kèm để bạn xem lỗi khi chạy nhé
Nhấp chuột vào đây để mở rộng...
Bạn gửi file lên chứ ảnh mình xem không biết lỗi ở chỗ nào.
 
Upvote 0
snow25 đã viết:
Bạn gửi file lên chứ ảnh mình xem không biết lỗi ở chỗ nào.
Nhấp chuột vào đây để mở rộng...
Sorry bạn nhé, mình up lên file nặng nên bị lỗi

Mình có khoảng 15 sheet, mỗi sheet khoảng 10-30k dòng để copy lại nên bạn xem giúp mình code để có thể mở rộng phạm vi copy nhé,

Có thể bổ sung giúp mình tên sheet ở Form để quản lý số dòng copy thì càng tốt ạ

Cám ơn bạn nhiều nhé
 

File đính kèm

Upvote 0
letuvan đã viết:
Sorry bạn nhé, mình up lên file nặng nên bị lỗi

Mình có khoảng 15 sheet, mỗi sheet khoảng 10-30k dòng để copy lại nên bạn xem giúp mình code để có thể mở rộng phạm vi copy nhé,

Có thể bổ sung giúp mình tên sheet ở Form để quản lý số dòng copy thì càng tốt ạ

Cám ơn bạn nhiều nhé
Nhấp chuột vào đây để mở rộng...
Bạn chạy code này xem nhé.
Mã: 
Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 35
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr > 8 Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              ReDim arr1(1 To UBound(arr, 1), 1 To 35): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 34).Value = arr1
         End If
     End If
  Next
End Sub
 

File đính kèm

Upvote 0
snow25 đã viết:
Bạn chạy code này xem nhé.
Mã: 
Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 35
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr > 8 Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              ReDim arr1(1 To UBound(arr, 1), 1 To 35): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 34).Value = arr1
         End If
     End If
  Next
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn rất nhiều nhé,
Mình chạy thấy ok rồi,
Cho mình hỏi thêm nếu chạy hơn 15 sheet có được ko bạn, mình thử file trên 15 sheet thì thấy từ sheet thứ 16 là ko copy thêm
 
Upvote 0
letuvan đã viết:
Cám ơn bạn rất nhiều nhé,
Mình chạy thấy ok rồi,
Cho mình hỏi thêm nếu chạy hơn 15 sheet có được ko bạn, mình thử file trên 15 sheet thì thấy từ sheet thứ 16 là ko copy thêm
Nhấp chuột vào đây để mở rộng...
Nó vẫn chạy hết mà.Bạn gửi file lên mình xem nhé.
 
Upvote 0

File đính kèm

  • FORM_V2.xlsm
    FORM_V2.xlsm
    101.1 KB · Đọc: 1
  • Untitled.png
    Untitled.png
    103 KB · Đọc: 3
Upvote 0
letuvan đã viết:
Bạn xem giúp mình file này nhé, Data nặng nên mình tạm xóa cho nhẹ, mình chạy thấy báo lỗi như hình,

Bạn xem giúp mình với nhé,
Cám ơn bạn nhiều
Nhấp chuột vào đây để mở rộng...
Đây bạn xem nhé.
Mã: 
Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
  Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 35
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr = Rows.Count Then lr = 8
           If sh.Range("a8").Value <> Empty Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              ReDim arr1(1 To UBound(arr, 1), 1 To 35): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 34).Value = arr1
         End If
     End If
  Next
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

Upvote 0
snow25 đã viết:
Đây bạn xem nhé.
Mã: 
Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
  Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 35
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr = Rows.Count Then lr = 8
           If sh.Range("a8").Value <> Empty Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              ReDim arr1(1 To UBound(arr, 1), 1 To 35): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 34).Value = arr1
         End If
     End If
  Next
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bạn rất nhiều, mình đã chạy thử và thành công
Chúc bạn sức khỏe và nhiều niềm vui
 
Upvote 0
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

dinhnhat91
  • Question Question
VBA Lỗi runtime error 9 subscript out of range
Trả lời
4
Đọc
70
ongke0711
ongke0711
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
1
Đọc
508
PhanTuHuong
PhanTuHuong
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
0
Đọc
49
Việt Nguyễn 86
Việt Nguyễn 86
K
Mong giúp dữ liệu từ trang web sang excel
Trả lời
0
Đọc
49
khanhvinhdai1
K
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
3
Đọc
1K
trung_bhxh
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
Trả lời
0
Đọc
76
trung_bhxh
T
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
52
Đọc
103K
khanhvinhdai1
K
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
3
Đọc
1K
Skyler113
Skyler113
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
5
Đọc
108
ptm0412
ptm0412
Huyen9
Lỗi không mailings được.
Trả lời
3
Đọc
84
vanle33
vanle33
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
14 15 16
Trả lời
310
Đọc
23K
kunkoi9390
K
K
Có ai giúp mình lấy kết quả xổ số miền nam về file excel
Trả lời
0
Đọc
42
khanhvinhdai1
K
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
H
Công thức tìm kết quả
Trả lời
11
Đọc
124
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
82
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
139
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
134
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
135
VetMini
V
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
420
A HOANG 620
A
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom