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

[sep_hatxel]

Mình có file excel mong GPE giúp đỡ! Chân thành cảm ơn!

 

[SA_DQ]

Bạn xài macro sau & những mong là khỏi đưa file lên

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'

 

[sep_hatxel]

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'

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!

 

[ThuNghi]

Option Explicit
Sub CopyFrom2Sheets()

End Sub

Chú í khi dùng: Tên các trang tính là 'S1', 'S2' & 'S0'

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.

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

 

[concogia]

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

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

 

[TrungChinhs]

Góp vui code này thử xem ?

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

 

[SA_DQ]

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!

 

[TrungChinhs]

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!

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

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

 

[ndu96081631]

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

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

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

 

[sep_hatxel]

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ẻ!

 

[concogia]

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ẻ!

Thủ code này nhé bạn

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

 

[ngochmcc]

Mình có file excel mong GPE giúp đỡ! Chân thành cảm ơn!

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):