Xin giúp đỡ , Chuyển thông tin Bảng A từ sheet data sang Sheet mới với Bảng A và thay đổi thông tin theo bảng B

[NTH.TQVN]

Tự động tạo các sheet mới theo tên sheet theo tên ở bảng B
Các sheet thay thế thông tin như trên chiều mũi tên trên hình
Ví dụ : sheet đầu tiên sẽ có tên sheet là Lò Thị Sen
Ô họ và tên là Lò Thị Sen và ID là VPV1011
các sheets tiếp theo sẽ là ID và tên kế tiếp
Mẫu như sheet 2 ạ!

 

[HUONGHCKT]

Làm xong test thử thấy cũng OK. Cũng toàn là ghi lại Macro cả thôi, nên góp ý thì nhận, ném đá thì xin đừng.
Đăng lên cho ai đó biết đâu cần đến để tham khảo.
Hy vọng code này có thể giúp ích được ai đó.

Option Explicit

Sub NhanBan()
Dim Sh As Worksheet, Ws As Worksheet
Dim i&, Lr&
Set Sh = Sheets("Data")
Lr = Sh.Cells(Rows.Count, "AH").End(xlUp).Row
For i = 2 To Lr
    Sh.Copy After:=Sheets(1)
Set Ws = Sheets("Data (2)")
    Ws.Name = Ws.Range("AI" & i)
    Ws.Range("P3") = Ws.Range("AI" & i)
    Ws.Range("P3") = Ws.Range("AI" & i)
    Ws.Range("AG1:AI" & Lr).ClearContents
    Sh.DrawingObjects.Copy
    Ws.Select
    Ws.Range("B9:I11").Select
    ActiveSheet.Pictures.Paste.Select
Next i
Set Sh = Nothing: Set Ws = Nothing
MsgBox "Done"
End Sub

 

[Maika8008]

Ở GPE ai dám ném đá, bạn. Góp ý rất nhẹ nhàng và nếu cần thì abc ... xyz luôn

 

[Hoàng Tuấn 868]

ném đá thì xin đừng.

Đang định ném giò ném chả đây này.

 

[HUONGHCKT]

Đang định ném giò ném chả đây này.

Ném giò, ném chả thì cho xin nhé, sãng sàng đón nhận, càng nhiều càng ít, bao nhiêu cũng được, đang thèm.

 

[NTH.TQVN]

Làm xong test thử thấy cũng OK. Cũng toàn là ghi lại Macro cả thôi, nên góp ý thì nhận, ném đá thì xin đừng.
Đăng lên cho ai đó biết đâu cần đến để tham khảo.
Hy vọng code này có thể giúp ích được ai đó.

Option Explicit

Sub NhanBan()
Dim Sh As Worksheet, Ws As Worksheet
Dim i&, Lr&
Set Sh = Sheets("Data")
Lr = Sh.Cells(Rows.Count, "AH").End(xlUp).Row
For i = 2 To Lr
    Sh.Copy After:=Sheets(1)
Set Ws = Sheets("Data (2)")
    Ws.Name = Ws.Range("AI" & i)
    Ws.Range("P3") = Ws.Range("AI" & i)
    Ws.Range("P3") = Ws.Range("AI" & i)
    Ws.Range("AG1:AI" & Lr).ClearContents
    Sh.DrawingObjects.Copy
    Ws.Select
    Ws.Range("B9:I11").Select
    ActiveSheet.Pictures.Paste.Select
Next i
Set Sh = Nothing: Set Ws = Nothing
MsgBox "Done"
End Sub

cảm ơn bạn rất nhiều ạ