Tổng hợp 2 sheet dữ liệu thành 1 (1 người xem)

Elx 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)
Bạn xài macro sau & những mong là khỏi đưa file lên

PHP: 
Option Explicit
Sub CopyFrom2Sheets()
 Dim Col As Byte, jJ As Long, lRw As Long
 Dim Sh1 As Worksheet, Sh2 As Worksheet
 
 Set Sh1 = Sheets("S1"):                     Set Sh2 = Sheets("S2")
 jJ = Sh1.Cells.Find(What:="*", After:=Sh1.[A1], SearchOrder:= _
   xlByColumns, SearchDirection:=xlPrevious).Column
 Col = Sh2.Cells.Find(What:="*", After:=Sh2.[A1], SearchOrder:= _
   xlByColumns, SearchDirection:=xlPrevious).Column
 If jJ > Col Then Col = jJ
 jJ = Sh1.Cells.Find(What:="*", After:=Sh1.[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
 lRw = Sh2.Cells.Find(What:="*", After:=Sh2.[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
 If jJ > lRw Then lRw = jJ
 Sheets("S0").Select:                        Cells.ClearContents
 For jJ = 1 To Col
   Cells(1, 2 * jJ - 1).Resize(lRw).Value = Sh1.Cells(jJ).Resize(lRw).Value
   Cells(1, 2 * jJ).Resize(lRw).Value = Sh2.Cells(jJ).Resize(lRw).Value
 Next jJ
End Sub

Chú í khi dùng: Tên các trang tính là 'S1', 'S2' & 'S0'
 
HYen17 đã viết:
PHP: 
Option Explicit
Sub CopyFrom2Sheets()
Dim Col As Byte, jJ As Long, lRw As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet

Set Sh1 = Sheets("S1"): Set Sh2 = Sheets("S2")
jJ = Sh1.Cells.Find(What:="*", After:=Sh1.[A1], SearchOrder:= _
xlByColumns, SearchDirection:=xlPrevious).Column
Col = Sh2.Cells.Find(What:="*", After:=Sh2.[A1], SearchOrder:= _
xlByColumns, SearchDirection:=xlPrevious).Column
If jJ > Col Then Col = jJ
jJ = Sh1.Cells.Find(What:="*", After:=Sh1.[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
lRw = Sh2.Cells.Find(What:="*", After:=Sh2.[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If jJ > lRw Then lRw = jJ
Sheets("S0").Select: Cells.ClearContents
For jJ = 1 To Col
Cells(1, 2 * jJ - 1).Resize(lRw).Value = Sh1.Cells(jJ).Resize(lRw).Value
Cells(1, 2 * jJ).Resize(lRw).Value = Sh2.Cells(jJ).Resize(lRw).Value
Next jJ
End Sub

Chú í khi dùng: Tên các trang tính là 'S1', 'S2' & 'S0'
Nhấp chuột vào đây để mở rộng...
Tuyệt lắm bạn HYen17! Cảm ơn bạn rất nhiều! Chúc ngày mới thắng lợi!
 
HYen17 đã viết:
PHP: 
Option Explicit
Sub CopyFrom2Sheets()

End Sub

Chú í khi dùng: Tên các trang tính là 'S1', 'S2' & 'S0'
Nhấp chuột vào đây để mở rộng...
Nếu em gán hết vào S0 và sort lại thì thời gian còn 1/4.
Còn nếu em dùng array thế range thì thời gian còn 1/3.
PHP: 
Sub CopyFrom2SheetsA()
Dim T
Dim iCol As Long, iCl As Long, iRw As Long, iRow As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet, myRng As Range
Dim Arr01(), Arr02()
T = Timer
Set Sh1 = Sheets("S1"):                     Set Sh2 = Sheets("S2")
With Sh1
 iCl = .Cells.Find(What:="*", After:=.[A1], SearchOrder:= _
  xlByColumns, SearchDirection:=xlPrevious).Column
 iRw = .Cells.Find(What:="*", After:=.[A1], SearchOrder:=xlByRows, _
  SearchDirection:=xlPrevious).Row
End With
If iCl > iCol Then iCol = iCl
If iRw > iRow Then iRow = iRw
With Sh2
 iCl = .Cells.Find(What:="*", After:=.[A1], SearchOrder:= _
   xlByColumns, SearchDirection:=xlPrevious).Column
 iRw = .Cells.Find(What:="*", After:=.[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
End With
If iCl > iCol Then iCol = iCl
If iRw > iRow Then iRow = iRw
With Sh1
  Arr01 = .Cells(1, 1).Resize(iRow, iCol).Value
End With
With Sh2
  Arr02 = .Cells(1, 1).Resize(iRow, iCol).Value
End With
Sheets("S0").Select
Cells.ClearContents
Cells(1, 1).Resize(iRow, iCol).Value = Arr01
Cells(1, 1).Offset(, iCol).Resize(iRow, iCol).Value = Arr02
Erase Arr01, Arr02
Set myRng = Cells(1, 1).Resize(iRow, iCol * 2)
With myRng
 .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
End With
Set myRng = Nothing
MsgBox Timer - T
End Sub
Sub CopyFrom2SheetsB()
Dim T
Dim iCol As Long, iCl As Long, iRw As Long, iRow As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Arr01(), Arr02(), ArrKQ()
T = Timer
Set Sh1 = Sheets("S1"):                     Set Sh2 = Sheets("S2")
With Sh1
 iCl = .Cells.Find(What:="*", After:=.[A1], SearchOrder:= _
  xlByColumns, SearchDirection:=xlPrevious).Column
 iRw = .Cells.Find(What:="*", After:=.[A1], SearchOrder:=xlByRows, _
  SearchDirection:=xlPrevious).Row
End With
If iCl > iCol Then iCol = iCl
If iRw > iRow Then iRow = iRw
With Sh2
 iCl = .Cells.Find(What:="*", After:=.[A1], SearchOrder:= _
   xlByColumns, SearchDirection:=xlPrevious).Column
 iRw = .Cells.Find(What:="*", After:=.[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
End With
If iCl > iCol Then iCol = iCl
If iRw > iRow Then iRow = iRw
With Sh1
  Arr01 = .Cells(1, 1).Resize(iRow, iCol).Value
End With
With Sh2
  Arr02 = .Cells(1, 1).Resize(iRow, iCol).Value
End With
ReDim ArrKQ(1 To iRow, 1 To iCol * 2)
For iCl = 1 To iCol
  For iRw = 1 To iRow
    ArrKQ(iRw, 2 * iCl - 1) = Arr01(iRw, iCl)
    ArrKQ(iRw, 2 * iCl) = Arr02(iRw, iCl)
  Next iRw
Next iCl
Sheets("S0").Select
Cells.ClearContents
Cells(1, 1).Resize(iRow, iCol * 2).Value = ArrKQ
Erase Arr01, Arr02, ArrKQ

MsgBox Timer - T
End Sub
 
Híc, nhìn code của chị Hải Yến và bạn Thu Nghi hoa cả mắt, cứ như đi trên Đào Hoa đảo của Hoàng dược sư vậy
Xin góp một cách nông dân _ nghĩ sao làm vậy cho nó ...dễ hiểu
Mã: 
Public Sub Gheplungtung()
    Dim Vung As Range, Sh, I As Integer, Cot As Integer
    Cells.Clear
        For I = 1 To 2
            Set Sh = Sheets("S" & I)
            Cot = Sh.[cw1].End(xlToLeft).Column
            Set Vung = Sh.Range(Sh.[a1], Sh.[a5000].End(xlUp)).Resize(, Cot)
                If [a1] = "" Then
                    [a1].Resize(Vung.Rows.Count, Cot) = Vung.Value
                Else
                    [cw1].End(xlToLeft)(1, 2).Resize(Vung.Rows.Count, Cot) = Vung.Resize(, Cot).Value
                End If
        Next
                        With ActiveWorkbook.Worksheets("S0").Sort
                            .Header = xlGuess
                            .MatchCase = False
                            .Orientation = xlLeftToRight
                            .SortMethod = xlPinYin
                            .Apply
                        End With
End Sub
 
Góp vui code này thử xem ?

Mã: 
Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
    Sheets("Sheet3").Cells.Clear
    Sheets("Sheet1").[a1].CurrentRegion.Resize(50000).Copy Sheets("Sheet3").[a1]
    Sheets("Sheet2").[a1].CurrentRegion.Resize(50000).Copy Sheets("Sheet3").[IV1].End(1)(1, 2)
    Cells.Sort [a1], 1, , , , , 2
End Sub
 

File đính kèm

Tuy có vài dòng code, nhưng khi chạy thì như vịt, vì

Bạn không xác định dòng cuối của dữ liệu mà ấn cho nó 5 vạn dòng thì ngất ngư chứ chả chơi!

Chúc vui!
 
HYen17 đã viết:
Bạn không xác định dòng cuối của dữ liệu mà ấn cho nó 5 vạn dòng thì ngất ngư chứ chả chơi!

Chúc vui!
Nhấp chuột vào đây để mở rộng...

Cảm ơn thầy đã nhắc nhở em mới nhớ đến thuộc tính UsetRange http://www.giaiphapexcel.com/forum/showthread.php?6419-Thuộc-tính-UsedRange&p=44286#post44286

Mã: 
Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
    Sheets("Sheet3").Cells.Clear
    Sheets("Sheet1").UsedRange.Copy Sheets("Sheet3").[a1]
    Sheets("Sheet2").UsedRange.Copy Sheets("Sheet3").[IV1].End(1)(1, 2)
    Cells.Sort [a1], 1, , , , , 2
End Sub
 
Lần chỉnh sửa cuối:
Trung Chinh đã viết:
Cảm ơn thầy đã nhắc nhở em mới nhớ đến thuộc tính UsetRange http://www.giaiphapexcel.com/forum/showthread.php?6419-Thuộc-tính-UsedRange&p=44286#post44286

Mã: 
Private Sub Worksheet_Activate()
Application.ScreenUpdating = 0
    Sheets("Sheet3").Cells.Clear
    Sheets("Sheet1").UsedRange.Copy Sheets("Sheet3").[a1]
    Sheets("Sheet2").UsedRange.Copy Sheets("Sheet3").[IV1].End(1)(1, 2)
    Cells.Sort [a1], 1, , , , , 2
End Sub
Nhấp chuột vào đây để mở rộng...
Chắc chắn không có cách nào nhanh hơn cách sort thông thương này (vì hầu như nó chẳng làm điều gì ghê gớm, cứ như ta làm bằng tay)
Thử nghiệm trên dữ liệu 50000 dòng trên mổi sheet thì cách của ThuNghi ra kết quả trong vòng 5s, cách của anh Trung Chinh ra kết quả trong vòng 2s
Mà nói chung thì cách dùng Sort Left to Right ta cảm giác tin tưởng hơn
Mà anh Trung Chinh nè, em thấy đoạn
Cells.Sort [a1], 1, , , , , 2
có vẽ không ổn
Em nghĩ nên vầy chứ
Sheets("Sheet3").UsedRange.Sort [A1], 1, , , , , , 1, , , 2
 
Vâng! Cảm ơn GPE rất nhiều! GPE có thể giúp mình làm trường hợp ngược lại được không ạ? Tức là nếu mình đã có sẵn kết quả là số liệu nhập theo số cột tự nhiên liên tiếp và bây giờ muốn tách ra sang 2 sheet khác: một sheet là số liệu theo cột chẵn và một sheet là số liệu theo cột lẻ!
 

File đính kèm

sep_hatxel đã viết:
Vâng! Cảm ơn GPE rất nhiều! GPE có thể giúp mình làm trường hợp ngược lại được không ạ? Tức là nếu mình đã có sẵn kết quả là số liệu nhập theo số cột tự nhiên liên tiếp và bây giờ muốn tách ra sang 2 sheet khác: một sheet là số liệu theo cột chẵn và một sheet là số liệu theo cột lẻ!
Nhấp chuột vào đây để mở rộng...
Thủ code này nhé bạn
Mã: 
Public Sub tach()
    Dim I As Long, J As Long, iCot As Long, Sh As Worksheet
    Application.ScreenUpdating = False
        iCot = [bw1].End(xlToLeft).Column
            For I = 1 To 2
                Set Sh = Sheets("Sheet" & I + 1)
                    For J = I To iCot Step 2
                        Cells(J).EntireColumn.Hidden = True
                    Next
                        Range([a1], [a5000].End(xlUp)).Resize(, iCot).SpecialCells(12).Copy Sh.[a1]
                        Cells.EntireColumn.Hidden = False
            Next
    Application.ScreenUpdating = True
End Sub
 
sep_hatxel đã viết:
Mình có file excel mong GPE giúp đỡ! Chân thành cảm ơn!
Nhấp chuột vào đây để mở rộng...

Mạn phép các thầy đã trả lời ở trên, em không quen dùng code; nên em dùng hàm có được không?
Hàm như sau: =IF(ISEVEN(COLUMN());INDEX(Sheet2!$A$1:$AJ$122;ROW();MATCH(COLUMN()+9;Sheet2!$A$1:$AJ$1;0));INDEX(Sheet1!$A$1:$AJ$122;ROW();MATCH(COLUMN()+9;Sheet1!$A$1:$AJ$1;0)))
Em trả lại file đã được làm (em lam tren 3 mang cung nhau ve kich thuc nhu file yeu cau kem theo):
 

File đính kèm

Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

C
Fix lỗi Application.InputBox Type:=8 (3 người xem)
    • Cười
Trả lời
5
Đọc
82
cdshtz88
C
L
Hỏi lỗi excel bị tràn trang khi in (1 người xem)
Trả lời
2
Đọc
57
vanle33
vanle33
Emyeuexcel
Tham chiếu về 1 ô-lấy ra và lọc dữ liệu (1 người xem)
Trả lời
4
Đọc
74
bigbabol89
bigbabol89
E
  • Question Question
VBA tự động thay đổi tham chiếu vùng (range và cell) khi insert dòng cột trong sheet tính toán (2 người xem)
    • Cười
Trả lời
5
Đọc
114
eagle12
E
D
Tổng hợp dữ liệu từ các sheet sang sheet tổng (1 người xem)
Trả lời
3
Đọc
141
dohungmo
D
T
font chu trong excel
Trả lời
2
Đọc
68
Hoàng Tuấn 868
H
khuong182018
  • Question Question
Nhờ anh chị sửa lỗi setfocus ở textbox
Trả lời
9
Đọc
162
khuong182018
khuong182018
N
File chia băng tự động từ cuộn mẹ theo khổ băng và khối lượng băng cho trước
Trả lời
0
Đọc
40
nguyenanhtruong2409
N
SA_DQ
Copilot bình luận về một ván cờ vua
Trả lời
0
Đọc
72
SA_DQ
SA_DQ
T
Xin giúp đỡ lọc dữ liệu (1 người xem)
    • Cười
Trả lời
4
Đọc
110
pycckuu410
pycckuu410
Nguyễn Duy Tuân
[New] BSAC v3.0 bộ công cụ lập trình phần mềm chuyên nghiệp trong VBA (1 người xem)
    • Thích
Trả lời
13
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản
Trả lời
8
Đọc
323
hieuvietmy2020
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (5 người xem)
    • Thích
6 7 8
Trả lời
778
Đọc
75K
SA_DQ
SA_DQ
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
12
Đọc
441
HUONGHCKT
H
V
Hỏi công thức để làm khối lượng trong xây dựng. Xin cảm ơn
Trả lời
11
Đọc
521
phanphu_91
P
Linhnv0001
Hỏi - Cách kiểm tra laptop là hàng lắp ráp hay không
Trả lời
3
Đọc
273
Lê Duy Thương
Lê Duy Thương
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
2
Đọc
186
Lê Duy Thương
Lê Duy Thương
L
[Mẹo] Không chọn Add-in vẫn có thể sử dụng được chức năng của Add-in, giảm tốc độ loading của Excel. (1 người xem)
    • Thích
Trả lời
2
Đọc
490
HeSanbi
HeSanbi
GPE-Trợ Lý
[GPE18] KỸ THUẬT BIỂU ĐỒ NÂNG CAO CHO DASHBOARD: TRỰC QUAN HÓA TIẾN ĐỘ THỰC HIỆN KẾ HOẠCH (1 người xem)
    • Thích
Trả lời
2
Đọc
9K
ptm0412
ptm0412
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
553
Đọc
72K
anh.nguyen287
anh.nguyen287
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom