Tổng hợp 2 sheet dữ liệu thành 1

Liên hệ QC
S

sep_hatxel

Thành viên thường trực
Tham gia
24/5/10
Bài viết
217
Được thích
7
Mình có file excel mong GPE giúp đỡ! Chân thành cảm ơn!
 

File đính kèm

  • Tonghop_2sheet_thanh1.rar
    37.8 KB · Đọc: 63
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

  • GopSheet.rar
    172.8 KB · Đọc: 28
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

  • Tach1sheet_thanh2sheet.rar
    37.5 KB · Đọc: 14
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

  • Tonghop_2sheet_thanh1 (bang lenh).xlsx
    56.9 KB · Đọc: 4
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

nghiky
Cách tìm kiếm và lọc số người
Trả lời
1
Đọc
45
snow25
snow25
Bạn Đoàn
Em có fille excel cần sử lý, mong anh chị giúp đỡ ạ, Em cảm ơn!
Trả lời
11
Đọc
196
huhumalu
H
T
Nhờ anh chụ giúp hiện tôi đang kết nối SQL Server lấy dữ liệu nhưng bị lỗi nên nhờ anh chị giúp
Trả lời
10
Đọc
112
ongke0711
ongke0711
dungnd.vcu
Tìm đơn giá mới nhất trong danh sách sản phẩm
2
Trả lời
22
Đọc
532
ptm0412
ptm0412
SA_DQ
Ngoại giao GẤU TRÚC (GT) là như thế nào?
    • Cười
    • Cảm ơn
Trả lời
3
Đọc
167
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom