Ghép nhiều sheet lại thành 1 sheet? (2 người xem)

[lắm chuyện]

Hic, em dốt đặc Excel, mong các bác tốt bụng giúp đỡ em tí

Diễn giải dài dòng ra thì là file excel của em có 50 trang, mỗi trang là data của 1 nước. Ô B1 của từng trang có ghi tên nước.
Giờ em làm thế nào để copy được đống tên nước ấy, sắp lại thành cái list?
Xong rồi sau đấy em có thể merge lại hết 50 nước trong 1 trang, mà cái cột đầu tiên là tên nước, cột thứ 2 trở đi mới bắt đầu là data (sắp xếp như trong file cũ) được không ạ? Nếu có thì các bác chỉ cho em làm thế nào với ạ! ;;-)

Em cảm ơn các bác trước ạ!

 

[nhanthienvandai]

Goi file do len anh xap xep lai va huong dan cho

 

[SA_DQ]

Mình tìm hiểu trong diễn đàn dùm bạn đây:

Bạn thử áp dụng đoạn mã sau, nò sẽ chép các Sheets vô 'Sheets("TgHop")'

[b]Public Sub CopyToSheet()[/b]
On Error Resume Next
Application.ScreenUpdating = False:     Application.Calculation = xlCalculationManual
Dim sht As Worksheet:                   Dim lRow As Long       [COLOR="blue"] ', LastRow As Long [/COLOR]
Dim VTemp, SRng As Range
For Each sht In Worksheets
    If sht.Name <> "TgHop" Then
        VTemp = sht.Range("B1").Value
        Set SRng = sht.UsedRange
        Sheets("TgHop").Select
[COLOR="Blue"]        'If WorksheetFunction.CountA(Cells) > 0 Then
  '       LastRow = Cells.Find(What:="*", After:=[A1], _
   '         SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'                                                  MsgBox LastRow
 '       End If [/COLOR]
        lRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
        Range("B" & lRow).Value = VTemp
        SRng.Copy Destination:=Worksheets("THop").Range("C" & lRow)
    End If
Next sht
Application.ScreenUpdating = True:      Application.Calculation = xlCalculationAutomatic [b]
End Sub[/b]

(ác bạn xem nó là của ai đấy?!

 

[Thien]

Dùng thử cái ni đi. Mình sử dụng cái này rất như ý

Option Explicit
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyTheUsedRangeOfEachSheet()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

On Error Resume Next
If Len(ThisWorkbook.Worksheets.Item("Master").Name) = 0 Then
On Error GoTo 0
Application.ScreenUpdating = False
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)

sh.UsedRange.Copy DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below to copy only the values
'or use the PasteSpecial option to paste the format also.
'With sh.UsedRange
'DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
'.Columns.Count).Value = .Value
'End With
'sh.UsedRange.Copy
'With DestSh.Cells(Last + 1, "A")
' .PasteSpecial xlPasteValues, , False, False
' .PasteSpecial xlPasteFormats, , False, False
' Application.CutCopyMode = False
'End With

End If
Next
DestSh.Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub

Thân chào

 

[lắm chuyện]

Cảm ơn các bác nhiều ạ! Nhất là bác Thien, em dùng theo đoạn code của bác, kết quả tốt ạ
Đoạn code của bác SA_DQ nó báo lỗi ạ. Mà em paste ra thấy mấy cái xuống dòng với dấu cách bị mất hết, chắc do thế nên nó mới có lỗi. Mà vẫn cảm ơn bác nhiều
Cuối cùng là cảm ơn bác nhanthienvandai có lòng

 

[SA_DQ]

?ntn

Đoạn code của bác SA_DQ nó báo lỗi. Mà em paste ra thấy mấy cái xuống dòng với dấu cách bị mất hết, chắc do thế nên nó mới có lỗi.

Nó báo lỗi như thế nào? Thông báo cho biết dùm để còn rút kinh nghiệm với chứ!

 

[dinhphuong9327]

Dùng thử cái ni đi. Mình sử dụng cái này rất như ý

Option Explicit
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyTheUsedRangeOfEachSheet()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

On Error Resume Next
If Len(ThisWorkbook.Worksheets.Item("Master").Name) = 0 Then
On Error GoTo 0
Application.ScreenUpdating = False
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)

sh.UsedRange.Copy DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below to copy only the values
'or use the PasteSpecial option to paste the format also.
'With sh.UsedRange
'DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
'.Columns.Count).Value = .Value
'End With
'sh.UsedRange.Copy
'With DestSh.Cells(Last + 1, "A")
' .PasteSpecial xlPasteValues, , False, False
' .PasteSpecial xlPasteFormats, , False, False
' Application.CutCopyMode = False
'End With

End If
Next
DestSh.Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub

Thân chào

Đoạn code trên hay quá. Nhưng có thể sửa lại là chỉ gán Value được không ạ. Hiện tại tại sheet "master" lấy tất cả nội dung từ các sheet bao gồm cả công thức.

Cám ơn mọi người

 

[quangmy05]

bác cho e hỏi chút , nếu bên sheet con thay đổi dữ liệu làm sao để nó tự động cập nhật dữ liệu. Mong bác giúp cho.
thanks.

 

[Lê Duy Thương]

bác cho e hỏi chút , nếu bên sheet con thay đổi dữ liệu làm sao để nó tự động cập nhật dữ liệu. Mong bác giúp cho.
thanks.

Tôi thì chỉ có thể giúp bạn khi có file. còn mọi vấn đề khác xin chịu

 

[Comonoo]

Kính gửi: Các bác,

Em có tham khảo rất nhiều Macro ghép dữ liệu nhiều sheet vào 01 sheet trong cùng 01 file excel; dòng lệnh của bác THIEN rất hay, tuy nhiên bác xem có fix lại dòng lệnh để dữ liệu tổng hợp chỉ chứa duy nhất 01 dòng tiêu đề của các sheet giống nhau không (hiện đang copy 100% dữ liệu của các sheet).
Em gửi file đính kèm, có 03 sheet "T1, T2, T3", em chạy thử Macro của bác THIEN nhưng lại mong muốn kết quả như sheet 1 trong file, các bác giúp em nhé!

Trân trọng cảm ơn!

 

[quanluu]

Kính gửi: Các bác,

Em có tham khảo rất nhiều Macro ghép dữ liệu nhiều sheet vào 01 sheet trong cùng 01 file excel; dòng lệnh của bác THIEN rất hay, tuy nhiên bác xem có fix lại dòng lệnh để dữ liệu tổng hợp chỉ chứa duy nhất 01 dòng tiêu đề của các sheet giống nhau không (hiện đang copy 100% dữ liệu của các sheet).
Em gửi file đính kèm, có 03 sheet "T1, T2, T3", em chạy thử Macro của bác THIEN nhưng lại mong muốn kết quả như sheet 1 trong file, các bác giúp em nhé!

Trân trọng cảm ơn!

bạn dùng code này

Public Sub GPE()
Dim dong As Long, td As Long
Dim sh As Worksheet
Application.ScreenUpdating = False
For Each sh In Worksheets
    If sh.Name <> "Sheet 1" Then
        dong = Application.WorksheetFunction.Count(sh.Range("B6:A1000"))
        td = td + dong
        Sheets("Sheet 1").Range("B" & (Sheets("Sheet 1").Range("B65000").End(xlUp).Row + 1)).Resize(dong, 3).Value = _
        sh.Range("B6").Resize(dong, 3).Value
    End If
Next
Sheets("Sheet 1").Range("A9:A" & (td + 8)).Value = [row(A:A)]
Application.ScreenUpdating = True
End Sub

 

[Comonoo]

Hi bác quanluu1989!

E có chạy code của bác nhưng báo lỗi "Run-time error '9' - Subscript out of range" bác ạ

 

[quanluu]

Hi bác quanluu1989!

E có chạy code của bác nhưng báo lỗi "Run-time error '9' - Subscript out of range" bác ạ

Mình nghi ngờ bi lỗi tại "Sheet 1"

bạn coi lại là bạn đang tôngr hợp file trên sheet này hay sheet khác và có tồn tại sheet này không?

 

[longhk]

Mình nghi ngờ bi lỗi tại "Sheet 1"

bạn coi lại là bạn đang tôngr hợp file trên sheet này hay sheet khác và có tồn tại sheet này không?

Cảm ơn bác, em cũng thử sửa lại tên sheet chạy ko báo lỗi nhưng vẫn xóa đc tiêu đề bị trùng bác ah.

 

[KhanhChi29]

nhờ mọi người sửa Code trong File để gộp các Sheet; Khi gộp, sheet tổng hợp sẽ không có công thức; (Copy giá trị)
Code trong File chạy gộp được các Sheet nhưng khi gộp sheet có công thức lên bị sai địa chỉ ô
Sub MergeSheets()
Const NHR = 1

Dim MWS As Worksheet
Dim AWS As Worksheet
Dim FAR As Long
Dim LR As Long

Set AWS = ActiveSheet

For Each MWS In ActiveWindow.SelectedSheets
If Not MWS Is AWS Then
FAR = AWS.UsedRange.Cells(AWS.UsedRange.Cells.Count).Row + 1
LR = MWS.UsedRange.Cells(MWS.UsedRange.Cells.Count).Row
MWS.Range(MWS.Rows(NHR + 1), MWS.Rows(LR)).Copy AWS.Rows(FAR)
End If
Next MWS
End Sub

 

[thuy.dk27]

Dùng thử cái ni đi. Mình sử dụng cái này rất như ý

Option Explicit
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
On Error GoTo 0
End Function

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", After:=sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyTheUsedRangeOfEachSheet()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

On Error Resume Next
If Len(ThisWorkbook.Worksheets.Item("Master").Name) = 0 Then
On Error GoTo 0
Application.ScreenUpdating = False
Set DestSh = ThisWorkbook.Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)

sh.UsedRange.Copy DestSh.Cells(Last + 1, "A")
'Instead of this line you can use the code below to copy only the values
'or use the PasteSpecial option to paste the format also.
'With sh.UsedRange
'DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
'.Columns.Count).Value = .Value
'End With
'sh.UsedRange.Copy
'With DestSh.Cells(Last + 1, "A")
' .PasteSpecial xlPasteValues, , False, False
' .PasteSpecial xlPasteFormats, , False, False
' Application.CutCopyMode = False
'End With

End If
Next
DestSh.Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub

Thân chào

Bạn cho mình hỏi đoạn code này có update được dữ lieu từ các sheet sau mỗi lần mình cập nhật thong tin không hay phải chạy lại.

 

[ha.pv89]

Các cao nhân giúp e với ạ. E ghép file mà nó báo lỗi này.
Code e dùng đây ạ


Sub GopFileExcel()

Dim FilesToOpen

Dim x As Integer



On Error GoTo ErrHandler

Application.ScreenUpdating = False



FilesToOpen = Application.GetOpenFilename _

(FileFilter:="Microsoft Excel Files (*.xls), *.xls", MultiSelect:=True, Title:="Files to Merge")



If TypeName(FilesToOpen) = "Boolean" Then

MsgBox "No Files were selected"

GoTo ExitHandler

End If



x = 1

While x <= UBound(FilesToOpen)

Workbooks.Open Filename:=FilesToOpen(x)

Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

x = x + 1

Wend



ExitHandler:

Application.ScreenUpdating = True

Exit Sub



ErrHandler:

MsgBox Err.Description

Resume ExitHandler

End Sub

 

[HUONGHCKT]

Kính gửi: Các bác,

Em có tham khảo rất nhiều Macro ghép dữ liệu nhiều sheet vào 01 sheet trong cùng 01 file excel; dòng lệnh của bác THIEN rất hay, tuy nhiên bác xem có fix lại dòng lệnh để dữ liệu tổng hợp chỉ chứa duy nhất 01 dòng tiêu đề của các sheet giống nhau không (hiện đang copy 100% dữ liệu của các sheet).
Em gửi file đính kèm, có 03 sheet "T1, T2, T3", em chạy thử Macro của bác THIEN nhưng lại mong muốn kết quả như sheet 1 trong file, các bác giúp em nhé!

Trân trọng cảm ơn!

Bạn dùng thử code này xem (vẫn là code của bạn @Thien , nhưng mình có sửa lại chút xíu, bổ sung chỉ định sheet không copy và có ghi chú nguồn ở sheet kết quả)