Nhờ giúp đỡ: Copy dữ liệu trên một sheet ra nhiều sheet tương ứng

[anhchanghamhoc]

Xin các pác cho mình code làm thao tác sau:
coppy dữ liệu từ 1 sheet TỔNG sang các sheet còn lại, mà việc coppy nay phải dựa vào sự dò tìm dữ liệu trong sheet TỔNG khớp với tên sheet được past dữ liệu qua
ví dụ:
tôi có 1 sheet TỔNG có nội dung sau:
SP01
SP01
SP01
SP02
SP02
SP02
SP02
SP03
SP03
SP03
SP03
SP03
.....
....
các sheet còn lại có tên sau:
sheet (01)
sheet (02)
sheet (03)
mình muốn những hàng SP01 được coppy sang sheet (01),SP02 được coppy sang sheet (02),SP03 được coppy sang sheet (03)
Xin các pác cho mình code thực hiện các thao tác trên!

 

[SA_DQ]

/)/(ột trong ~ cách mà bạn có thể tham khảo, như sau:

[b]Sub CopyToSheets()[/b]
 Sheets("S0").Select
 Dim vAR, Rng1 As Range, Rng2 As Range, Rng3 As Range
 Dim Ij As Long
 Ij = 1
 Do
    Ij = 1 + Ij:                Range("B" & CStr(Ij)).Select
[color="Blue"]'Xét tại cột 'B' [/color]
    With Selection
        If Len(.Value) < 1 Then Exit Do
        vAR = Right(.Value, 1)
        Select Case vAR
        Case 1
            If Rng1 Is Nothing Then
                Set Rng1 = .EntireRow
            Else
                Set Rng1 = Union(Rng1, .EntireRow)
            End If
        Case 2
            If Rng2 Is Nothing Then
                Set Rng2 = .EntireRow
            Else
                Set Rng2 = Union(Rng2, .EntireRow)
            End If
        Case 3
            If Rng3 Is Nothing Then
                Set Rng3 = .EntireRow
            Else
                Set Rng3 = Union(Rng3, .EntireRow)
            End If
        End Select
    End With
 Loop
 Rng1.Copy Destination:=Worksheets("S1").Range("A1")
 Rng2.Copy Destination:=Worksheets("S2").Range("A1")
 Rng3.Copy Destination:=Worksheets("S3").Range("A1")
[color="Blue"]'Copy đến 3 Sheets 'S1', 'S2' & 'S3' tương ứng[/color]
[b]End Sub[/b]

Macro này có thể hoàn thiện thêm, nếu chúng ta muốn!

 

[anhchanghamhoc]

nhưng công việc của mình là làm trên nhiểu sheet (khoản 200 sheet)
nếu làm như pác thỉ code này viết phải dài lắm!

Nhưng công việc của mình làm, thì dữ liệu trong sheet TỔNG thì nhiều SP, nên có rất nhiểu sheet tương ứng (khoảng 200 sheet), nếu dùng code này thì viết lại quá dài !
các pác còn code nào gọn hơn xin cho mình với, thank you các pác trước nhé!

 

[anhchanghamhoc]

các pác có code nào đơn gian mà gọn nhẹ hơn không xin cho tớ với các pác ơi, mình cần lắm !
các pác có thể viết hoàn chỉnh để mình vận dụng luôn mình cần lắm!
cám ơn các pác nhiều lắm!!!!!

 

[SA_DQ]

Xin tham khảo nha:

 Option Explicit
 Const SoSheets = 99
[B] Sub CopyToSheets()[/b]
 On Error GoTo Loi_Copy
 Sheets("S0").Select
 ReDim MRng(1 To SoSheets) As Range:               Dim StrC As String
 Dim Ij As Long:                            Dim iZ As Integer
 Ij = 1
 Do
    Ij = 1 + Ij:                Range("B" & CStr(Ij)).Select
    With Selection
        If Len(.Value) < 1 Then Exit Do
        For iZ = 1 To SoSheets
            If (Mid(.Value, 3)) = iZ Then
                If MRng(iZ) Is Nothing Then
                    Set MRng(iZ) = .EntireRow
                Else
                    Set MRng(iZ) = Union(MRng(iZ), .EntireRow)
                End If
            End If
        Next iZ
        
    End With
 Loop
 For iZ = 1 To SoSheets
    StrC = "S" & CStr(iZ)
    MRng(iZ).Copy Destination:=Worksheets(StrC).Range("A1")
 Next iZ
Err_Copy:           Exit Sub
Loi_Copy:
    MsgBox Error, , StrC & Str(iZ)
    Resume Err_Copy
[b] End Sub [/b]

** (hú í: Khai báo hằng SoSheets theo số lượng Sheets mà bạn có;
Tên các sheets của bạn theo kiểu 'Nxxx' ( mà N là chuỗi & xxx là các số tăng dần) Điều này để tiện cho việc sử dụng trong vòng lặp!

 

[anhchanghamhoc]

Mình thử rồi nhưng không được, mình sẽ post lên nhờ pac xem hộ, cám ơn pác trước nha!
trong đó mình muốn dữ liệu trong sheet1 tự động coppy qua các sheet còn lại tương ứng với số: SP3048 coppy vào sheet(3048),SP3049 coppy vào sheet(3049),.....

 

[SA_DQ]

Option Explicit
 Const SoSheets = 99
 [b]Sub CopyToSheets()[/b]
 On Error GoTo Loi_Copy
 Sheets("Sheet1").Select
 XepMa
 ReDim MRng(1 To SoSheets) As Range:               Dim StrC As String
 ReDim MTemp(1 To SoSheets)
 Dim Ij As Long:                            Dim iZ As Integer
 Ij = 1:                                     iZ = 0
 Do
    Ij = 1 + Ij:                Range("A" & CStr(Ij)).Select
    With Selection
        If Len(.Value) < 1 Then Exit Do:
        If StrC <> .Value Then
            StrC = .Value:              iZ = iZ + 1
            MTemp(iZ) = "N" & Mid(.Value, 3)
[color="blue"]' Tên Sheets sẽ là N3048, N3049, . . ., N3052. [/color]
            Set MRng(iZ) = .EntireRow
        Else
            Set MRng(iZ) = Union(MRng(iZ), .EntireRow)
        End If
    End With
 Loop
 
 For iZ = 1 To SoSheets
    StrC = MTemp(iZ)
    MRng(iZ).Copy Destination:=Worksheets(StrC).Range("A1")
 Next iZ
 
Err_Copy:           Exit Sub
Loi_Copy:
    MsgBox Error, , StrC & Str(iZ)
    Resume Err_Copy
[b] End Sub[/b]

[b]
Sub XepMa()[/b]
    Columns("A:C").Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
[b]End Sub[/b]

Chú ý:
1./ Mình làm thêm macro để xếp trật tự các record, phòng ngừa ai đó nhập không theo thứ tự
2./ Tên các Sheets mình đã đổi # so với bạn; và không nên gán ~ tên như (1254) hay chỉ là 321 . . . tự gây khó dễ cho mình

 

[anhchanghamhoc]

Nhưng nếu không đặt tên sheet (3049) thì nó lại gây khó cho mình trong việc tạo các sheet, vì khi tạo các sheet mình dùng coppymove,nếu không làm như vậy nó sẽ không chạy theo thứ tự: (3049),(3050),..
Pác làm thẳng vào file mình post lên luôn dụm, cám ớn pác nhiều lắm!
mình đang rất cần cái code này!

 

[Mr Okebab]

Mình nghĩ, đâu cần phải nhiều Sheet như vậy. 2 Sheet là đủ rồi. Chiều mình sẽ up lên.

Xin lỗi các bạn khi đã Spam bài (Bài không có nội dung _ Theo ý mình hiểu).

Bạn thử xem qua file này nhé.
Pass : GPE

Thân!

 

[SA_DQ]

Nhưng nếu không đặt tên sheet (3049) thì nó lại gây khó cho mình trong việc tạo các sheet, vì khi tạo các sheet mình dùng coppymove,nếu không làm như vậy nó sẽ không chạy theo thứ tự: (3049),(3050),..
Pác làm thẳng vào file mình post lên luôn dụm, cám ớn pác nhiều lắm!
mình đang rất cần cái code này!

Mình đã làm thẳng rồi đó;
Bây chừ chỉ còn vấn đề là tên Sheets mà thôi;
Lúc đó với câu lệnh:

MTemp(iZ) = "N" & Mid(.Value, 3)

Sẽ viết như sau:

 MTemp(iZ)="(" & Mid(.Value, 3) & ")"

là xong thôi;


(òn théc méc còn zảii đáp! - Hãy đợi đấy!

 

[nvson]

Bạn thử file sau!

 

[anhchanghamhoc]

- Mình làm được rồi cảm ơn pác nhe! Pác SA QD TUYỆT LẮM!!!!!!!!
- Còn của pác Hieu thì mình thử rồi, khi chọn sp thì dữ liệu trong bảng chi tiết không chạy theo!

 

[Mr Okebab]

- Còn của pác Hieu thì mình thử rồi, khi chọn sp thì dữ liệu trong bảng chi tiết không chạy theo!

Xin lỗi khi nhầm công thức để lọc. Đây là File hoàn chỉnh


Thân!