Copy nhiều sheet sang một sheet kèm theo tên của sheet (1 người xem)

dungnvps · 3/11/16

Chào mọi người, tôi có 1 file copy nhiều sheet sang 1 sheet, tôi muốn hỏi là có cách nào khi copy thì copy kèm theo cả tên sheet ko? Chân thành cám ơn

giaiphap · 3/11/16

dungnvps đã viết:
Chào mọi người, tôi có 1 file copy nhiều sheet sang 1 sheet, tôi muốn hỏi là có cách nào khi copy thì copy kèm theo cả tên sheet ko? Chân thành cám ơn

View attachment 167956

Vậy bạn sửa code cho nút Copy như sau:

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "Total" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.[a1].CurrentRegion.Offset(1, 0).Copy Destination:=.Offset()
            
        End With
[COLOR=#ff0000][B]        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name[/B][/COLOR]
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

dungnvps · 3/11/16

giaiphap đã viết:

Vậy bạn sửa code cho nút Copy như sau:

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "Total" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.[a1].CurrentRegion.Offset(1, 0).Copy Destination:=.Offset()
            
        End With
[COLOR=#ff0000][B]        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name[/B][/COLOR]
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

Bạn ơi, tên sheet thì lấy đc nhưng mà nó copy luôn sheet "TOTAL"

giaiphap · 3/11/16

dungnvps đã viết:
Bạn ơi, tên sheet thì lấy đc nhưng mà nó copy luôn sheet "TOTAL"

Là do chổ màu đỏ này nè bạn, tên Sheet bạn đặt chữ hoa còn điều kiện bạn thì chữ thường.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "[COLOR=#ff0000][B]TOTAL[/B][/COLOR]" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.[a1].CurrentRegion.Offset(1, 0).Copy Destination:=.Offset()
        End With
        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

dungnvps · 3/11/16

giaiphap đã viết:

Là do chổ màu đỏ này nè bạn, tên Sheet bạn đặt chữ hoa còn điều kiện bạn thì chữ thường.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "[COLOR=#ff0000][B]TOTAL[/B][/COLOR]" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.[a1].CurrentRegion.Offset(1, 0).Copy Destination:=.Offset()
        End With
        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

Ra lỗi do mình, cảm ơn bạn nhiều!!

dungnvps · 4/11/16

giaiphap đã viết:

Là do chổ màu đỏ này nè bạn, tên Sheet bạn đặt chữ hoa còn điều kiện bạn thì chữ thường.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "[COLOR=#ff0000][B]TOTAL[/B][/COLOR]" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.[a1].CurrentRegion.Offset(1, 0).Copy Destination:=.Offset()
        End With
        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

Bạn cho mình hỏi thêm vấn đề nữa, có cách nào để copy lần lượt các cột ko? ví dụ như cột A-C

giaiphap · 4/11/16

dungnvps đã viết:
Bạn cho mình hỏi thêm vấn đề nữa, có cách nào để copy lần lượt các cột ko? ví dụ như cột A-C

Có chứ, để copy từng cột bạn xem thử cách này.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "TOTAL" Then
        With [B65500].End(xlUp).Offset(1)
            'Copy cot B o cac sheet sang cot C cua sheet TOTAL
            Sh.Range("B2", Sh.[B65500].End(xlUp)).Copy Destination:=.Offset(, 1)
            'Copy cot D o cac sheet sang cot E cua sheet TOTAL
            Sh.Range("D2", Sh.[D65500].End(xlUp)).Copy Destination:=.Offset(, 3)
        End With
        Range([A65500].End(xlUp).Offset(1), [C65500].End(xlUp).Offset(, -2)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

dungnvps · 4/11/16

giaiphap đã viết:

Có chứ, để copy từng cột bạn xem thử cách này.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "TOTAL" Then
        With [B65500].End(xlUp).Offset(1)
            'Copy cot B o cac sheet sang cot C cua sheet TOTAL
            Sh.Range("B2", Sh.[B65500].End(xlUp)).Copy Destination:=.Offset(, 1)
            'Copy cot D o cac sheet sang cot E cua sheet TOTAL
            Sh.Range("D2", Sh.[D65500].End(xlUp)).Copy Destination:=.Offset(, 3)
        End With
        Range([A65500].End(xlUp).Offset(1), [C65500].End(xlUp).Offset(, -2)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

Cám ơn bạn nhiều!! --=0

dungnvps · 4/11/16

giaiphap đã viết:

Có chứ, để copy từng cột bạn xem thử cách này.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(1, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "TOTAL" Then
        With [B65500].End(xlUp).Offset(1)
            'Copy cot B o cac sheet sang cot C cua sheet TOTAL
            Sh.Range("B2", Sh.[B65500].End(xlUp)).Copy Destination:=.Offset(, 1)
            'Copy cot D o cac sheet sang cot E cua sheet TOTAL
            Sh.Range("D2", Sh.[D65500].End(xlUp)).Copy Destination:=.Offset(, 3)
        End With
        Range([A65500].End(xlUp).Offset(1), [C65500].End(xlUp).Offset(, -2)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

Xin lỗi lại làm phiền bạn, nhưng mình có chỉnh format của file tí, mình đã sửa lại code nhưng lại bị lỗi, cảm phiền bạn có thể xem qua giúp mình đc ko!!

giaiphap · 4/11/16

Bạn sửa lại thế này nhé.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(3, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "TOTAL" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.Range("A4", Sh.[A65500].End(xlUp)).Resize(, 9).Copy Destination:=.Offset()
        End With
        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

dungnvps · 5/11/16

giaiphap đã viết:

Bạn sửa lại thế này nhé.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(3, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "TOTAL" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.Range("A4", Sh.[A65500].End(xlUp)).Resize(, 9).Copy Destination:=.Offset()
        End With
        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

Cám ơn bạn, nhưng có thể dùng code lấy từng cột đc ko? vì sau này nếu có chèn cột vào các vị trí khác nhau thì có thế chỉnh sử dễ dàng...

dungnvps · 5/11/16

giaiphap đã viết:

Bạn sửa lại thế này nhé.

Mã:

Sub Button1_Click()
Dim Sh As Worksheet
Application.ScreenUpdating = False
[a1].CurrentRegion.Offset(3, 0).ClearContents
For Each Sh In Worksheets
    If Sh.Name <> "TOTAL" Then
        With [B65500].End(xlUp).Offset(1)
            Sh.Range("A4", Sh.[A65500].End(xlUp)).Resize(, 9).Copy Destination:=.Offset()
        End With
        Range([A65500].End(xlUp).Offset(1), [B65500].End(xlUp).Offset(, -1)) = Sh.Name
    End If
Next Sh
Application.ScreenUpdating = True
End Sub

mình dựa theo code của bạn mình chỉnh lại đc rồi, cám ơn bạn nhiều

Copy nhiều sheet sang một sheet kèm theo tên của sheet (1 người xem)

Người dùng đang xem chủ đề này

dungnvps

Thành viên chính thức

File đính kèm

giaiphap

==(^o^)==

dungnvps

Thành viên chính thức

giaiphap

==(^o^)==

dungnvps

Thành viên chính thức

dungnvps

Thành viên chính thức

giaiphap

==(^o^)==

dungnvps

Thành viên chính thức

dungnvps

Thành viên chính thức

File đính kèm

giaiphap

==(^o^)==

dungnvps

Thành viên chính thức

dungnvps

Thành viên chính thức

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

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

Đếm ngược thời gian