Code copy sang sheet khác

hmloan · 16/11/09

Nhờ các anh/chi chỉ dùm em!
Em muốn copy tất cả các dòng có điều kiện là '003' trong cột 'DEPTCD' sang 'Sheet2', tất cả các dòng có điều kiện không phải là '<>NKO', '<>CRO', '<>003', '<>AHO' trong cột 'DEPTCD' sang 'Sheet3' thì em phải làm sao. Hướng giải quyết như thế nào.
Thanks các anh/chị rất nhiều.

SA_DQ · 16/11/09

Bạn thử xài con macro này & kiểm lại xem sao?

PHP:

Option Explicit
Sub CopyAll()
 Dim Sh As Worksheet, Clls As Range, Rng As Range
 Const StrC As String = "NKO.GPE.CRO003AHO"
 Set Sh = Sheet1:             Application.ScreenUpdating = False
 Sheet2.[B2].CurrentRegion.Clear
 Sheet3.[B2].CurrentRegion.Clear
 For Each Clls In Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
   With Clls.Resize(, 5)
      If InStr(StrC, Clls.Value) > 0 Then
         Set Rng = Sheet2.[A65500].End(xlUp).Offset(1)
         If Clls.Value = "003" Then _
            Rng.Resize(, 5).Value = .Value
            Rng.NumberFormat = "00#"
      Else
         Sheet3.[A65500].End(xlUp).Offset(1).Resize(, 5).Value = .Value
      End If
   End With
 Next
End Sub

sealand · 16/11/09

Bạn dùng sub này xem nhé , mình Modi của bác Sa đấy. Mình test thấy được

Mã:

Sub chep()
Dim Rng As Range
Sheet2.Cells.ClearContents
Sheet3.Cells.ClearContents
With Sheet1
.Range("A1:E100").AutoFilter Field:=1, Criteria1:="=003"
        Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible)
 Rng.Copy Destination:=Sheet2.Range("A1")
.[a1:e100].AutoFilter Field:=1, Criteria1:="<>003"
        Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible)
 Rng.Copy Destination:=Sheet3.Range("A1")
 End With

End Sub

ChanhTQ@ · 16/11/09

To SEALAND

Hình như tác giả viết hơi bị thừa trong câu:

Trong cột 'DEPTCD', tất cả các dòng có điều kiện không phải là '<>NKO', '<>CRO', '<>003', '<>AHO' trong cột 'DEPTCD' sang 'Sheet3' thì em phải làm sao.

Nên làm anh "Đất cảng" chép quá dư chăng?

sealand · 16/11/09

ChanhTQ@ đã viết:
Hình như tác giả viết hơi bị thừa trong câu:

Nên làm anh "Đất cảng" chép quá dư chăng?

Thôi chết, mình nhầm là còn lại chép sang sheet3. Xin lỗi nha

tam8678 · 16/11/09

HYen17 đã viết:

PHP:

Option Explicit
Sub CopyAll()
 Dim Sh As Worksheet, Clls As Range, Rng As Range
 Const StrC As String = "NKO.GPE.CRO003AHO"
 Set Sh = Sheet1:             Application.ScreenUpdating = False
 Sheet2.[B2].CurrentRegion.Clear
 Sheet3.[B2].CurrentRegion.Clear
 For Each Clls In Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
   With Clls.Resize(, 5)
      If InStr(StrC, Clls.Value) > 0 Then
         Set Rng = Sheet2.[A65500].End(xlUp).Offset(1)
         If Clls.Value = "003" Then _
            Rng.Resize(, 5).Value = .Value
            Rng.NumberFormat = "00#"
      Else
         Sheet3.[A65500].End(xlUp).Offset(1).Resize(, 5).Value = .Value
      End If
   End With
 Next
End Sub

---
Mong anh hướng dẫn và giải thích giúp code trên.
Cám ơn

SA_DQ · 16/11/09

Sẵn lòng thôi!

tam8678 đã viết:
Option Explicit
Sub CopyAll()
1 Dim Sh As Worksheet, Clls As Range, Rng As Range
Const StrC As String = "NKO.GPE.CRO003AHO"
3 Set Sh = Sheet1: Application.ScreenUpdating = False
Sheet2.[B2].CurrentRegion.Clear
5 Sheet3.[B2].CurrentRegion.Clear
For Each Clls In Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
7 With Clls.Resize(, 5)
If InStr(StrC, Clls.Value) > 0 Then
9 Set Rng = Sheet2.[A65500].End(xlUp).Offset(1)
If Clls.Value = "003" Then _
11 Rng.Resize(, 5).Value = .Value
Rng.NumberFormat = "00#"
13 Else
Sheet3.[A65500].End(xlUp).Offset(1).Resize(, 5).Value = .Value
15 End If
End With
17 Next
End Sub

(1): Khai báo 3 biến đối tượng cần dùng;
(2) Khai 1 hằng cần dùng; Hằng gồm tổ hợp các nhóm từ cần tìm kiếm.
(3) Phần đâu: Gán trang tính vô biến đối tượng;
Phần sau: Không cho lắc lư, đảo điên nàn hình
(4) & (5) Xóa vùng dử liệu do racro trước đó tạo ra;
(6) Tạo vòng lặp For. . Next duyệt hết các ô dữ liệu (tại cột đầu của trang tính 1)
(7) đến (16) Ta sẽ làm việc với ô được gán cho biến Clls, được mở rọng sang phải thêm 4 cột nữa;
(8) Nêu dữ liệu chứa trong Clls có trong hằng StrC (đã khai báo) thì thực hiện các lệnh tiếp sau cho đến dòng 12;
(9) Lấy ô cuối cùng có chứa dữ liệu, thêm 1 hàng thuộc trang tính 2 & đem gán vô biến đã khai báo
(Như tiếng Tàu, nên đọc ngược các dòng lệnh dễ hiểu hơn!)
(10) Nếu trị đó là '003' thì thực hiện 2 lệnh tiếp sau
Đó là: (11) Lấy các dữ liệu chứa trong các ô từ trong biến Rng, phát triển về bên phải thêm 4 ô đem gán vô mà ta đã tuyên cáo sẽ làm việc với chúng (Tại dòng lệnh (7))
(12) Địa chỉ ô chứa trong Rng được định dạng số theo kiểu '00#' (Thêm số 0 nếu chuỗi kí số chưa đủ 3)
(13) Nếu điều kiện ( Theo dòng (8)) không thỏa, ta phải thực thi lệnh (14)
Đó là: Đem dữ liệu trong vùng ta tuyên cáo làm việc với nó (dòng(7)) đem gán vô ô mà được thêm 1 dòng so với dòng cuối cùng chứa dữ liệu của trang tính 3

Các dòng còn lại như là những kết thúc cần thiết của điều kiện hay vòng lặp đã dựng tạo bên trên

Chúc vui!

Nhân đây xin đố các bạn sao trong hằng có chứa nhóm từ ".GPE."!

tam8678 · 16/11/09

Không hiểu chổ này anh ơi:

Const StrC As String = "NKO.GPE.CRO003AHO"
(2) Khai 1 hằng cần dùng; Hằng gồm tổ hợp các nhóm từ cần tìm kiếm.

Lúc ban đầu anh viết (liên tục) là "NKOGPECRO003AHO"
Sau anh sửa lại như trên, dấu chấm nằm giữa từ NKO, GPE và CRO003AHO để làm gì anh nhỉ? Có thể viết như thế này được không: "NKO.CRO.003.AHO".
Mong được anh giúp.

ChanhTQ@ · 16/11/09

Có thể viết như thế này được không: "NKO.CRO.003.AHO".

Còn gì bằng
& nói thêm, nếu không có các dấu chấm thì nó gặp nhóm chuỗi sau cũng sẽ thực thi các lệnh
"KOC"; "OCR" cũng như "RO0" hay "O00", hoặc "3AH' nó cũng mần ráo trọi thì lãnh nợ là cái chắc!
Nói thêm, nếu các mã đó có chứa ký tự '.' thì ta phải xài sang '@' vậy!

Chúc khỏe nhiều! :-=

hmloan · 16/11/09

HYen17 đã viết:

PHP:

Option Explicit
Sub CopyAll()
 Dim Sh As Worksheet, Clls As Range, Rng As Range
 Const StrC As String = "NKO.GPE.CRO003AHO"
 Set Sh = Sheet1:             Application.ScreenUpdating = False
 Sheet2.[B2].CurrentRegion.Clear
 Sheet3.[B2].CurrentRegion.Clear
 For Each Clls In Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
   With Clls.Resize(, 5)
      If InStr(StrC, Clls.Value) > 0 Then
         Set Rng = Sheet2.[A65500].End(xlUp).Offset(1)
         If Clls.Value = "003" Then _
            Rng.Resize(, 5).Value = .Value
            Rng.NumberFormat = "00#"
      Else
         Sheet3.[A65500].End(xlUp).Offset(1).Resize(, 5).Value = .Value
      End If
   End With
 Next
End Sub

Nhờ các anh sữa dùm code.
Các anh xem dùm em phần này với. Sao khi em chạy đoạn code này xong, nó sẽ chép qua các 'Sheet' và em muốn bỏ luôn dòng đầu tiên không có dữ liệu. Và ở 'Sheet7' điều kiện '003' chỉ còn số '3' ah. Em phải làm sao bây giờ. Anh chỉ em với. Thanks anh rất nhiều

hmloan · 16/11/09

sealand đã viết:

Bạn dùng sub này xem nhé , mình Modi của bác Sa đấy. Mình test thấy được

Mã:

Sub chep()
Dim Rng As Range
Sheet2.Cells.ClearContents
Sheet3.Cells.ClearContents
With Sheet1
.Range("A1:E100").AutoFilter Field:=1, Criteria1:="=003"
        Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible)
 Rng.Copy Destination:=Sheet2.Range("A1")
.[a1:e100].AutoFilter Field:=1, Criteria1:="<>003"
        Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible)
 Rng.Copy Destination:=Sheet3.Range("A1")
 End With

End Sub

Gởi anh sealand!
Theo em biết thì đoạn code này

PHP:

 .[a1:e100].AutoFilter Field:=1, Criteria1:="<>003"
        Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible)

chỉ có tối đa 2 điều kiện ah, còn em muốn tất cả các dòng có điều kiện không phải là '<>NKO', '<>CRO', '<>003', '<>AHO' trong cột 'DEPTCD' sang 'Sheet3' thì em phải làm sao. Mong sớm nhận được hồi âm của anh. Thanks anh nhiều.

ChanhTQ@ · 16/11/09

Tạm thời làm như vầy; Đang cố gọn hơn

hmloan đã viết:
Nhờ các anh sữa dùm code.
Sao khi em chạy đoạn code này xong, sẽ chép qua các Sheet(i);
Em muốn bỏ luôn dòng đầu tiên không có dữ liệu.
Ở 'Sheet7' điều kiện '003' chỉ còn số '3' ah. Em phải làm sao bây giờ.

PHP:

Sub mCopy()
    Dim Sh As Worksheet, Clls As Range, Rng As Range
    Const StrC As String = "NKO.CRO.APO.AHO.CAD.CSD."
        
    For Each Sh In Worksheets
      If Sh.Name <> "Sheet1" Then Sh.[b2].CurrentRegion.Clear
    Next Sh
    Set Sh = Sheet1:             Application.ScreenUpdating = False
    For Each Clls In Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
        With Clls.Resize(, 5)
            If InStr(StrC, Clls.Value) > 0 Then
                If Clls.Value = "NKO" Then
                    Set Rng = Sheet2.[A65500].End(xlUp).Offset(1)
                    Rng.Resize(, 5).Value = .Value
                ElseIf Clls.Value = "CRO" Then
                    Set Rng = Sheet3.[A65500].End(xlUp).Offset(1)
                    Rng.Resize(, 5).Value = .Value
                ElseIf Clls.Value = "APO" Then
                    Set Rng = Sheet4.[A65500].End(xlUp).Offset(1)
                    Rng.Resize(, 5).Value = .Value
                ElseIf Clls.Value = "AHO" Then
                    Set Rng = Sheet5.[A65500].End(xlUp).Offset(1)
                    Rng.Resize(, 5).Value = .Value
                ElseIf (Clls.Value = "CAD" Or Clls.Value = "CSD") Then
                    Set Rng = Sheet6.[A65500].End(xlUp).Offset(1)
                    Rng.Resize(, 5).Value = .Value
                End If
            Else
                Sheet7.[A65500].End(xlUp).Offset(1).Resize(, 5).Value = .Value
                Sheet7.[A65500].End(xlUp).NumberFormat = "00#"
            End If
        End With
    Next
    For Each Sh In Worksheets
      If Sh.Name <> "Sheet1" Then Sh.[b1].EntireRow.Delete
    Next Sh
End Sub

sealand · 17/11/09

Mình sửa lại code bài trước, phần 2 mình lọc Advance Filter.
Mình cố tình theo con đường này vì không dùng vòng lặp mà lợi dụng các chức năng sẵn có của Excel nên có thể tốc độ cao hơn. Khi vào số liệu thực tế lớn sẽ có lợi hơn.

Mã:

Sub chep()
Dim Rng, Rng1 As Range
Application.ScreenUpdating = False
Sheet2.Cells.ClearContents
Sheet3.Cells.ClearContents
With Sheet1
.[s1] = .[a1]: .[t1] = .[a1]: .[u1] = .[a1]: .[v1] = .[a1]:
.[s2] = "<>APO": .[t2] = "<>CRO": .[u2] = "<>003*": .[v2] = "<>AHO"
.Range("A1:E100").AutoFilter Field:=1, Criteria1:="=003"
Set Rng = .AutoFilter.Range.Offset(1, 0).Resize(.AutoFilter.Range.Rows. _
                   Count - 1).SpecialCells(xlCellTypeVisible)
 Rng.Copy Destination:=Sheet2.Range("A1")
.Range("A1:E100").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("S1:V2")
 Set Rng = .Range("A1:E" & .Range("b56536").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
 Rng.Copy Destination:=Sheet3.Range("A1")
 .[s1:v2].ClearContents
 .ShowAllData
 End With
 With Sheet3
Set Rng = .[a2].Resize(.[b56536].End(xlUp).Row, 5)
 Rng.Copy Destination:=.Range("A1")
End With
Application.ScreenUpdating = True
End Sub

SA_DQ · 17/11/09

To SeaLand

Từ #10 tác giả đã điều chỉnh yêu cầu, rằng là chép ra làm 6 trang tính khác nhau; trong đó trang cuối là những gì ô hợp chưa chép ở các trang trước nó chưa chép;

Mình nghĩ cũng có thể xây dựng vòng lặp lọc Advanced sau đó chép lần lượt vô các trang này;

Nhưng với sáng nắng chiều mưa, sợ khó bảo trì & phát triển macro mà thôi!

Thân ái!

ChanhTQ@ · 17/11/09

Muốn AdvancedFilter thì có AdvancedFilter

PHP:

Option Explicit
Sub AdvancedFilter()
 Dim Sh As Worksheet, Rng As Range, cRng As Range, dRng As Range
 Dim jJ As Byte, eRw As Long
 
 eRw = [A65500].End(xlUp).Row:               Sheet1.Select
 Range("H1:M1").Value = [A1].Value
 Set Rng = [A1].Resize(eRw, 5)
 For jJ = 1 To 6
   [H2].Resize(2, 6).Clear
   If jJ < 5 Then
      [H2].Value = Switch(jJ = 1, "NKO", jJ = 2, "CRO", jJ = 3, "APO", jJ = 4, "AHO")
      Set cRng = [H1].Resize(2)
   ElseIf jJ = 5 Then
      [H2].Value = "CAD":        [I3] = "CSD"
      Set cRng = [H1].Resize(3, 2)
   Else
      [H2].Value = "<>CAD":        [I2].Value = "<>CSD":    [J2].Value = "<>NKO"
      [K2].Value = "<>CRO":        [L2].Value = "<>APO":    [M2].Value = "<>AHO"
      Set cRng = [H1].Resize(2, 6)
   End If
   Rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=cRng, _
      CopyToRange:=Range("H5:L5"), Unique:=False
   Set Sh = Sheets(Switch(jJ = 1, "NKO", jJ = 2, "CRO", jJ = 3, "APO", jJ = 4, "AHO", _
      jJ = 5, "C2D", jJ = 6, "NoAll", jJ = 7, "GPE"))
   Sh.[B2].CurrentRegion.Clear
   [H5].CurrentRegion.Offset(1).Copy Destination:=Sh.[A1]
 Next jJ
End Sub

sealand · 18/11/09

Xin cám ơn bác Sa chỉ giùm, em xin sửa lại File cho hoàn thiện

thuong.nguyen@laviewater.com · 18/11/09

Lưu dữ liệu liên tiếp vào 1 sheet khác

file của em có 3 sheet: sheet 1 để nhập dữ liệu, sheet 2 để in các dữ liệu ra, sheet 3 để lưu vào theo dõi. Nhưng mỗi khi lưu xong, xoá đi để nhập thông tin khác vào thì cứ bị lưu đè vào phần trước đã lưu mà không lưu lien tiếp được vào các dòng ở phía dưới. Các đại ca giúp em tạo lại code được không? Thanks

ChanhTQ@ · 18/11/09

Hình như NICK của bạn chưa đúng với nội quy thì phải?

thuong.nguyen@laviewater.com đã viết:
IV.Quy định về Nick đăng ký:

Nick đăng ký không được có các ký tự đặc biệt như * / \ ? : " ( )

Nick đăng ký phải tuân thủ những quy định như những quy định về nội dung và hình thức bài viết.

Nick đăng ký tránh việc nhái cái nick khác. Đặc biệt là các nick có thể gây mạo nhận là thành viên Ban Điều Hành diễn đàn.

Nick đăng ký không được có dạng của một địa chỉ email hoặc một địa chỉ website.

Nếu vậy sẽ không có ai trả lời cho bạn đâu, thật đáng tiếc!

Thân ái!

hmloan · 19/11/09

Nhờ các anh giúp đỡ

Một số dòng lệnh duới đây em không hiểu. Các anh giải thích dùm em với.

PHP:

Sheet1.[A65500].End(xlUp).Offset(1).Resize( , 5)
Sheet1.[A65500].End(xlUp)  ?
.Offset(1)    ?
.Offset(1,0)  ?
.Resize(2)    ?
.Resize(3,2)  ?
.Resize(, 5)  ?

CurrentRegion  ?

With Sheet1
        .[t1] = .[a1]: .[v1] = .[a1]:
        .[t2] = "<>NKO": .[v2] = "<>CRO"

    Tương tự như 2 dòng dưới đúng không anh. Còn dấu ":" có nghĩa là gì.

        Sheet1.[t1] = Sheet1.[a1]: Sheet1.[v1] = Sheet1.[a1]: 
        Sheet1.[t2] = "<>NKO": Sheet1.[v2] = "<>CRO" 
End With

ChanhTQ@ · 19/11/09

hmloan đã viết:
Một số dòng lệnh duới đây em không hiểu. Các anh giải thích dùm em với.

PHP:

Sheet1.[A65500].End(xlUp).Offset(1).Resize( , 5)
' Ví dụ chúng ta có dòng dữ liệu cuối cùng đang là A17: Z17'
'Thì dòng lệnh này sẽ kích hoạt các ô [A18:E18] '
Sheet1.[A65500].End(xlUp)  ' Cũng tợ như từ [Â500] ta bấm đồng thời 2 fím {CTRL} & mũi tên lên í mà' 
.Offset(1)    ' Giống hàm OFFSET() trong excel thôi : Dịch xuống dưới 1 hàng'
.Offset(1,0)  ? ' Tương đương cầu trên'
.Resize(2)    ? ' Ví dụ [A2].Resize(2)  sẽ mở rọng xuống dưới đến [A4]'
.Resize(3,2)  ? ' Chỉ số đầu chỉ mở rọng theo trục đứng, còn kia theo phải trái'
.Resize(, 5)  ? ' Không mở rọng theo hàng, chỉ mở theo 5 cột nữa' 

CurrentRegion  ? 'Vùng đang có dữ liệu Xem thêm tại chữ ký của SA_DQ'

With Sheet1
        .[t1] = .[a1]: .[v1] = .[a1]:
 ' Ô t1 được gán trị từ ô A1 & ô V1 cũng rứa'
        .[t2] = "<>NKO": .[v2] = "<>CRO"
  ' Tương tợ'
    Tương tự như 2 dòng dưới đúng không anh. Còn dấu ":" có nghĩa là gì.
'Dấu : phân cách dòng lệnh; Báo cho VBA biết là dòng này đang có 2 dòng lệnh'
' Còn dấu _ để nối 2 dòng quá dài thành 1 dòng lệnh'
' Như trên' 
        Sheet1.[t1] = Sheet1.[a1]: Sheet1.[v1] = Sheet1.[a1]: 
        Sheet1.[t2] = "<>NKO": Sheet1.[v2] = "<>CRO" 
End With

Code copy sang sheet khác

Thành viên mới

File đính kèm

/(hông là gì!

Thành viên gạo cội

File đính kèm

0901452không62

Thành viên gạo cội

Đời Xá Chi

/(hông là gì!

Đời Xá Chi

0901452không62

Thành viên mới

File đính kèm

Thành viên mới

0901452không62

Thành viên gạo cội

File đính kèm

/(hông là gì!

0901452không62

Thành viên gạo cội

File đính kèm

Thành viên mới

File đính kèm

0901452không62

Thành viên mới

0901452không62

Đếm ngược thời gian