Ghép nhiều sheet lại thành 1 sheet?

Liên hệ QC
lắm chuyện

lắm chuyện

Thành viên mới
Tham gia
3/4/07
Bài viết
2
Được thích
0
Hic, em dốt đặc Excel, mong các bác tốt bụng giúp đỡ em tí
help.gif


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 ạ!
biggrin.gif
 
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")'
Mã: 
[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?!
 
Lần chỉnh sửa cuối:
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
 
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 ạ :D
Đ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 :p
 
?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.
Nhấp chuột vào đây để mở rộng...
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ứ!
 
Thien đã viết:
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
Nhấp chuột vào đây để mở rộng...

Đ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
 
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.
 
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!
 

File đính kèm

  • File thuong.xls
    27.5 KB · Đọc: 268
Comonoo đã viết:
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!
Nhấp chuột vào đây để mở rộng...
bạn dùng code này
Mã: 
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
 
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 ạ :(
 
Comonoo đã viết:
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 ạ :(
Nhấp chuột vào đây để mở rộng...
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?
 
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
 

File đính kèm

  • Gop sheet.xlsm
    20.9 KB · Đọc: 61
Thien đã viết:
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
Nhấp chuột vào đây để mở rộng...
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.
 
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
 

File đính kèm

  • z2568128128661_675964049d56cba65f54592b3090119e.jpg
    z2568128128661_675964049d56cba65f54592b3090119e.jpg
    85.6 KB · Đọc: 5
Comonoo đã viết:
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!
Nhấp chuột vào đây để mở rộng...
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ả)
 

File đính kèm

  • File thuong cua ban Comonoo.xlsm
    26.7 KB · Đọc: 35
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
3 4 5
Trả lời
84
Đọc
2K
ptm0412
ptm0412
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
26
Đọc
666
VetMini
V
P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
4
Đọc
208
phantu93
P
V
công thức của nó là gì ạ. mong mọi người giúp
Trả lời
1
Đọc
82
CHAOQUAY
C
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
13
Đọc
313
ongke0711
ongke0711
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