Giúp mình macro copy dòng thỏa điều kiện với ạ!

Liên hệ QC
V

vnlife2000

Thành viên chính thức
Tham gia
3/4/07
Bài viết
71
Được thích
0
Em chào anh/chị. Em muốn copy các dòng trong excel thỏa điều kiện. Em đính kèm file nhờ a/c giúp em với ạ. Cảm ơn anh chị
 

File đính kèm

  • Copy dong.xlsm
    18.2 KB · Đọc: 22
Bạn thử với con macro này xem sao:
PHP: 
Sub CopySang2SheetTheoDieuKien()
 Dim Tinh As String
 Dim Cls As Range, Rng As Range, Sh As Worksheet
 Dim lRw As Long
 
 Tinh = [N5].Value
 For Each Cls In Range([E5], [E5].End(xlDown))
    If Cls.Value = Tinh Then
        Set Sh = ThisWorkbook.Worksheets("Sheet2")
        lRw = Sh.[A65500].End(xlUp).Row
        Cls.Interior.ColorIndex = 35
    Else
        Set Sh = ThisWorkbook.Worksheets("Sheet3")
        lRw = Sh.[A65500].End(xlUp).Row
        Cls.Interior.ColorIndex = 38
    End If
    Cls.Offset(, -3).Resize(, 3).Copy Destination:=Sh.Cells(lRw + 1, "B")
    Sh.Cells(lRw + 1, "A").Value = 1 + Sh.Cells(lRw, "A").Value
 Next Cls
End Sub
 
vnlife2000 đã viết:
Em chào anh/chị. Em muốn copy các dòng trong excel thỏa điều kiện. Em đính kèm file nhờ a/c giúp em với ạ. Cảm ơn anh chị
Nhấp chuột vào đây để mở rộng...
Cách khác
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&,sRow&, i&

  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets(Sh3)
    eRow = .Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value
    Set rng = .Range("B5", .Range("E" & Rows.Count).End(xlUp))
  End With
  sRow = rng.Rows.Count
  For i = 1 To rng.Rows.Count
    If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
    With Sheets(Sh)
      eRow = .Range("E" & Rows.Count).End(xlUp).Row
      rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1)
    End With
  Next i
  Application.ScreenUpdating = True
End Sub
 
Ý kiến cho phần code chính của bài #3 như vầy:

Đoạn
With Sheets(Sh2)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
With Sheets(Sh3)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
Có thể sửa thành (để tránh lặp lại code)
For Each meSh In Array(Sh2, Sh3)
With Sheets(meSh)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
Next meSh

Đoạn
For i = 1 To rng.Rows.Count
If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
With Sheets(Sh)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1)
End With
Next i
Có thể sửa thành (để tránh phải dùng con toán tìm dòng cuối liên tục)
aSh = Array(Sheets(Sh2), Sheets(Sh3))
aRw = Array( aSh(0).Range("E" & Rows.Count).End(xlUp).Row, aSh(1).Range("E" & Rows.Count).End(xlUp).Row )
For i = 1 To rng.Rows.Count
meSheet = IIF(rng(i, 4).Value = DK, 0, 1)
aRw(meSheet) = aRw(meSheet) + 1
rng(i, 1).Resize(, 4).Copy aSh(meSheet).Range("B" & aRw(meSheet))
Next i
 
phulien1902 đã viết:
Lập trình mà để cột STT trống rỗng là 1 điều thiếu sót?
Nhấp chuột vào đây để mở rộng...
SA_DQ đã viết:
Bạn thử với con macro này xem sao:
PHP: 
Sub CopySang2SheetTheoDieuKien()
Dim Tinh As String
Dim Cls As Range, Rng As Range, Sh As Worksheet
Dim lRw As Long

Tinh = [N5].Value
For Each Cls In Range([E5], [E5].End(xlDown))
    If Cls.Value = Tinh Then
        Set Sh = ThisWorkbook.Worksheets("Sheet2")
        lRw = Sh.[A65500].End(xlUp).Row
        Cls.Interior.ColorIndex = 35
    Else
        Set Sh = ThisWorkbook.Worksheets("Sheet3")
        lRw = Sh.[A65500].End(xlUp).Row
        Cls.Interior.ColorIndex = 38
    End If
    Cls.Offset(, -3).Resize(, 3).Copy Destination:=Sh.Cells(lRw + 1, "B")
    Sh.Cells(lRw + 1, "A").Value = 1 + Sh.Cells(lRw, "A").Value
Next Cls
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều ạ.
Bài đã được tự động gộp:

HieuCD đã viết:
Cách khác
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&,sRow&, i&

  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets(Sh3)
    eRow = .Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value
    Set rng = .Range("B5", .Range("E" & Rows.Count).End(xlUp))
  End With
  sRow = rng.Rows.Count
  For i = 1 To rng.Rows.Count
    If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
    With Sheets(Sh)
      eRow = .Range("E" & Rows.Count).End(xlUp).Row
      rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1)
    End With
  Next i
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn Hiếu CD rất nhiều ạ. Bạn hiệu chỉnh code giúp mình chỉ copy đến cột D (không copy đến cột E) sửa như thế nào ạ.
Bài đã được tự động gộp:

phulien1902 đã viết:
Lập trình mà để cột STT trống rỗng là 1 điều thiếu sót?
Nhấp chuột vào đây để mở rộng...
Vì mình dùng công thức chỗ đó nhảy số thứ tự rồi ạ.
 
vnlife2000 đã viết:
Cảm ơn bạn nhiều ạ.
Bài đã được tự động gộp:


Cảm ơn bạn Hiếu CD rất nhiều ạ. Bạn hiệu chỉnh code giúp mình chỉ copy đến cột D (không copy đến cột E) sửa như thế nào ạ.
Bài đã được tự động gộp:


Vì mình dùng công thức chỗ đó nhảy số thứ tự rồi ạ.
Nhấp chuột vào đây để mở rộng...
rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1)
Số 4 là copy 4 cột từ cột B đến cột E
Chỉnh lại
rng(i, 1).Resize(, 3).Copy .Range("B" & eRow + 1)
 
vnlife2000 đã viết:
Bạn xem lại giúp, sao cho ra kết quả copy có 1 dòng à bạn
Nhấp chuột vào đây để mở rộng...
Mình quên chỉnh dòng cuối
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, i&
 
  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets(Sh3)
    eRow = .Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value
    Set rng = .Range("B5", .Range("E" & Rows.Count).End(xlUp))
  End With
  sRow = rng.Rows.Count
  For i = 1 To rng.Rows.Count
    If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
    With Sheets(Sh)
      eRow = .Range("B" & Rows.Count).End(xlUp).Row
      rng(i, 1).Resize(, 3).Copy .Range("B" & eRow + 1)
    End With
  Next i
  Application.ScreenUpdating = True
End Sub
Bài đã được tự động gộp:

vnlife2000 đã viết:
Bạn xem lại giúp, sao cho ra kết quả copy có 1 dòng à bạn
Nhấp chuột vào đây để mở rộng...
Rút gọn code khó hiểu hơn
Mã: 
Sub ABC()
  Dim rng As Range, aSh
  Dim DK$, n&, eRow&, i&
 
  Application.ScreenUpdating = False
  aSh = Array("Sheet2", 8, "Sheet3", 8)
  For i = 0 To 2 Step 2
    eRow = Sheets(aSh(i)).Range("E" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then Sheets(aSh(i)).Range("A8:E" & eRow).Clear
  Next i
  With Sheets("Sheet1")
    DK = .Range("N5").Value
    Set rng = .Range("B5", .Range("E" & Rows.Count).End(xlUp))
  End With
  sRow = rng.Rows.Count
  For i = 1 To rng.Rows.Count
    If rng(i, 4).Value = DK Then n = 0 Else n = 2
    With Sheets(aSh(n))
      rng(i, 1).Resize(, 3).Copy .Range("B" & aSh(n + 1))
      aSh(n + 1) = aSh(n + 1) + 1
    End With
  Next i
  Application.ScreenUpdating = True
End Sub
 
Lần chỉnh sửa cuối:
Sub ABCnew()
Dim rng As Range
Dim DK$, Sh$, Sh2$, Sh3$, eRow&, i&

Application.ScreenUpdating = False
Sh2 = "Sheet2": Sh3 = "Sheet3"
With Sheets(Sh2)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
With Sheets(Sh3)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
With Sheets("Sheet1")
DK = .Range("N5").Value
Set rng = .Range("B5", .Range("E" & Rows.Count).End(xlUp))
End With
sRow = rng.Rows.Count
For i = 1 To rng.Rows.Count
If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
With Sheets(Sh)
eRow = .Range("B" & Rows.Count).End(xlUp).Row
rng(i, 1).Resize(, 3).copy .Range("B" & eRow + 1)
End With
Next i
Application.ScreenUpdating = True
End Sub
Cảm ơn bạn nhiều lắm. Code chạy rồi nhưng mình chưa hiểu hết các dòng lệnh. Nhờ bạn chú thích giúp ạ.
 
Lần chỉnh sửa cuối:
vnlife2000 đã viết:
Sub ABCnew()
Dim rng As Range
Dim DK$, Sh$, Sh2$, Sh3$, eRow&, i&

Application.ScreenUpdating = False
Sh2 = "Sheet2": Sh3 = "Sheet3"
With Sheets(Sh2)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
With Sheets(Sh3)
eRow = .Range("E" & Rows.Count).End(xlUp).Row
If eRow > 7 Then .Range("A8:E" & eRow).Clear
End With
With Sheets("Sheet1")
DK = .Range("N5").Value
Set rng = .Range("B5", .Range("E" & Rows.Count).End(xlUp))
End With
sRow = rng.Rows.Count
For i = 1 To rng.Rows.Count
If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
With Sheets(Sh)
eRow = .Range("B" & Rows.Count).End(xlUp).Row
rng(i, 1).Resize(, 3).copy .Range("B" & eRow + 1)
End With
Next i
Application.ScreenUpdating = True
End Sub
Cảm ơn bạn nhiều lắm. Code chạy rồi nhưng mình chưa hiểu hết các dòng lệnh. Nhờ bạn chú thích giúp ạ.
Nhấp chuột vào đây để mở rộng...
Hy vọng bạn hiểu
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, sRow&, i&
 
  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 7 Then .Range("A8:D" & eRow).Clear 'Xoa Tu dong 8 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:D" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value 'Dieu kien
    eRow = .Range("E" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    Set rng = .Range("B5:E" & eRow) 'Vung du lieu "rng" tu dong 5 toi dong cuoi, tu cot B toi cot E
  End With
  sRow = rng.Rows.Count 'So dong Vung du lieu "rng"
  For i = 1 To sRow
    If rng(i, 4).Value = DK Then Sh = Sh2 Else Sh = Sh3
    With Sheets(Sh) 'Sheet ket qua
      eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
      rng(i, 1).Resize(, 3).Copy .Range("B" & eRow + 1) ' copy dong i, 3 cot tu cot B (B,C,D)
    End With
  Next i
  Application.ScreenUpdating = True
End Sub
 
Bạn giúp mình thêm tý:Nếu copy qua sheet3 bỏ 1 cột thì sửa sao ạ. ví dụ muốn copy sheet1 từ cột B đến D qua sheet3 cột B đến C và cột D bên sheet1 thì copy qua cột E bên sheet3 ạ.
 
vnlife2000 đã viết:
Bạn giúp mình thêm tý:Nếu copy qua sheet3 bỏ 1 cột thì sửa sao ạ. ví dụ muốn copy sheet1 từ cột B đến D qua sheet3 cột B đến C và cột D bên sheet1 thì copy qua cột E bên sheet3 ạ.
Nhấp chuột vào đây để mở rộng...
Không rỏ ý bạn như thế nào
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, sRow&, i&
 
  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 7 Then .Range("A8:D" & eRow).Clear 'Xoa Tu dong 8 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value 'Dieu kien
    eRow = .Range("E" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    Set rng = .Range("B5:E" & eRow) 'Vung du lieu "rng" tu dong 5 toi dong cuoi, tu cot B toi cot E
  End With
  sRow = rng.Rows.Count 'So dong Vung du lieu "rng"
  For i = 1 To sRow
    If rng(i, 4).Value = DK Then
      With Sheets(Sh2) 'Sheet2
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 3).Copy .Range("B" & eRow + 1) ' copy dong i, 3 cot tu cot B (B,C,D)
      End With
    Else
      With Sheets(Sh3) 'Sheet3
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
      End With
    End If
  Next i
  Application.ScreenUpdating = True
End Sub
 
vnlife2000 đã viết:
Bạn giúp mình thêm tý:Nếu copy qua sheet3 bỏ 1 cột thì sửa sao ạ. ví dụ muốn copy sheet1 từ cột B đến D qua sheet3 cột B đến C và cột D bên sheet1 thì copy qua cột E bên sheet3 ạ.
Nhấp chuột vào đây để mở rộng...
Mình đã làmđược rồi bạn Hiếu ơi.Nhờ bạn chú thích á. Nhưng nó chạy chậm lắm bạn, đợi tầm mấy phút luôn.
HieuCD đã viết:
Không rỏ ý bạn như thế nào
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, sRow&, i&

  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 7 Then .Range("A8:D" & eRow).Clear 'Xoa Tu dong 8 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value 'Dieu kien
    eRow = .Range("E" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    Set rng = .Range("B5:E" & eRow) 'Vung du lieu "rng" tu dong 5 toi dong cuoi, tu cot B toi cot E
  End With
  sRow = rng.Rows.Count 'So dong Vung du lieu "rng"
  For i = 1 To sRow
    If rng(i, 4).Value = DK Then
      With Sheets(Sh2) 'Sheet2
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 3).Copy .Range("B" & eRow + 1) ' copy dong i, 3 cot tu cot B (B,C,D)
      End With
    Else
      With Sheets(Sh3) 'Sheet3
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
      End With
    End If
  Next i
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
Code này mình muốn copy 2 cột từ cột B(B C) còn cột D thì copy đến cột E ạ
Bài đã được tự động gộp:

HieuCD đã viết:
Không rỏ ý bạn như thế nào
Mã: 
Sub ABC()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, sRow&, i&

  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 7 Then .Range("A8:D" & eRow).Clear 'Xoa Tu dong 8 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value 'Dieu kien
    eRow = .Range("E" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    Set rng = .Range("B5:E" & eRow) 'Vung du lieu "rng" tu dong 5 toi dong cuoi, tu cot B toi cot E
  End With
  sRow = rng.Rows.Count 'So dong Vung du lieu "rng"
  For i = 1 To sRow
    If rng(i, 4).Value = DK Then
      With Sheets(Sh2) 'Sheet2
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 3).Copy .Range("B" & eRow + 1) ' copy dong i, 3 cot tu cot B (B,C,D)
      End With
    Else
      With Sheets(Sh3) 'Sheet3
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
      End With
    End If
  Next i
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Bạn xem sheet ạ.
 

File đính kèm

  • Copy dong.new.xlsm
    23 KB · Đọc: 7
Lần chỉnh sửa cuối:
Mã: 
Sub COPYROW()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, sRow&, i&
  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 12 Then .Range("B13:H" & eRow).Clear 'Xoa Tu dong 13 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 12 Then .Range("B13:F" & eRow).Clear
    '.Range("I13:I" & eRow).Clear     ' Xoa cot I
  End With
  With Sheets("Sheet1")
    DK = .Range("AA5").Value 'Dieu kien
    eRow = .Range("H" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    Set rng = .Range("B4:H" & eRow) 'Vung du lieu "rng" tu dong 5 toi dong cuoi, tu cot B toi cot E
  End With
  sRow = rng.Rows.Count 'So dong Vung du lieu "rng"
  For i = 1 To sRow
    If rng(i, 7).Value <> DK Then
      With Sheets(Sh2) 'Sheet2
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 6).copy .Range("B" & eRow + 1) ' copy dong i, 3 cot tu cot B (B,C,D)
      End With
    Else
      With Sheets(Sh3) 'Sheet3
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 5).copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
        rng(i, 6).Resize(, 1).copy .Range("I" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
      End With
    End If
  Next i
  Application.ScreenUpdating = True
End Sub
Cảm ơn bạn Hiếu CD, mình đã làm được rồi ạ. Nhưng bạn có thể cải tiến để chạy nhanh hơn được không ạ.
 
vnlife2000 đã viết:
Mã: 
Sub COPYROW()
  Dim rng As Range
  Dim DK$, Sh$, Sh2$, Sh3$, eRow&, sRow&, i&
  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 12 Then .Range("B13:H" & eRow).Clear 'Xoa Tu dong 13 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 12 Then .Range("B13:F" & eRow).Clear
    '.Range("I13:I" & eRow).Clear     ' Xoa cot I
  End With
  With Sheets("Sheet1")
    DK = .Range("AA5").Value 'Dieu kien
    eRow = .Range("H" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    Set rng = .Range("B4:H" & eRow) 'Vung du lieu "rng" tu dong 5 toi dong cuoi, tu cot B toi cot E
  End With
  sRow = rng.Rows.Count 'So dong Vung du lieu "rng"
  For i = 1 To sRow
    If rng(i, 7).Value <> DK Then
      With Sheets(Sh2) 'Sheet2
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 6).copy .Range("B" & eRow + 1) ' copy dong i, 3 cot tu cot B (B,C,D)
      End With
    Else
      With Sheets(Sh3) 'Sheet3
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 5).copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
        rng(i, 6).Resize(, 1).copy .Range("I" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
      End With
    End If
  Next i
  Application.ScreenUpdating = True
End Sub
Cảm ơn bạn Hiếu CD, mình đã làm được rồi ạ. Nhưng bạn có thể cải tiến để chạy nhanh hơn được không ạ.
Nhấp chuột vào đây để mở rộng...
Chạy code mới
Mã: 
Sub ABC()
  Dim DK$, Sh2$, Sh3$, eRow&

  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 7 Then .Range("A8:E" & eRow).Clear 'Xoa Tu dong 8 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value 'Dieu kien
    eRow = .Range("E" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    .Range("B4").AutoFilter Field:=5, Criteria1:=DK 'Loc theo dieu kien
    .Range("B5:E" & eRow).Copy Sheets(Sh2).Range("B8") 'Copy
    .Range("B4").AutoFilter Field:=5, Criteria1:="<>" & DK 'Loc theo khác dieu kien
    .Range("B5:C" & eRow).Copy Sheets(Sh3).Range("B8") 'Copy
    .Range("D5:D" & eRow).Copy Sheets(Sh3).Range("E8") 'Copy
    .Range("B4").AutoFilter
  End With
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Chạy code mới
Mã: 
Sub ABC()
  Dim DK$, Sh2$, Sh3$, eRow&

  Application.ScreenUpdating = False
  Sh2 = "Sheet2": Sh3 = "Sheet3"
  With Sheets(Sh2)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
    If eRow > 7 Then .Range("A8:E" & eRow).Clear 'Xoa Tu dong 8 toi dong cuoi tu cot A toi cot D
  End With
  With Sheets(Sh3)
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 7 Then .Range("A8:E" & eRow).Clear
  End With
  With Sheets("Sheet1")
    DK = .Range("N5").Value 'Dieu kien
    eRow = .Range("E" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot E
    .Range("B4").AutoFilter Field:=5, Criteria1:=DK 'Loc theo dieu kien
    .Range("B5:E" & eRow).Copy Sheets(Sh2).Range("B8") 'Copy
    .Range("B4").AutoFilter Field:=5, Criteria1:="<>" & DK 'Loc theo khác dieu kien
    .Range("B5:C" & eRow).Copy Sheets(Sh3).Range("B8") 'Copy
    .Range("D5:D" & eRow).Copy Sheets(Sh3).Range("E8") 'Copy
    .Range("B4").AutoFilter
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Mã: 
For i = 1 To sRow
    If rng(i, 7).Value <> DK Then
      With Sheets(Sh2) 'Sheet2
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 6).copy .Range("B" & eRow + 1) ' copy dong i, 6 cot tu cot B (B,C,D,E,F,G)
      End With
    Else
      With Sheets(Sh3) 'Sheet3
        eRow = .Range("B" & Rows.Count).End(xlUp).Row 'Dòng cuoi cot B
        rng(i, 1).Resize(, 5).copy .Range("B" & eRow + 1) ' copy dong i, 5 cot tu cot B (B,C,D,E,F)
        rng(i, 6).Resize(, 1).copy .Range("I" & eRow + 1) ' copy dong i, 1 cot tu G
      End With
    End If
  Next i
Bạn dịch đoạn này qua code mới giúp mình với ạ
 
vnlife2000 đã viết:
Mình đã làmđược rồi bạn Hiếu ơi.Nhờ bạn chú thích á. Nhưng nó chạy chậm lắm bạn, đợi tầm mấy phút luôn.

rng(i, 1).Resize(, 4).Copy .Range("B" & eRow + 1) ' copy dong i, 4 cot tu cot B (B,C,D,E)
Code này mình muốn copy 2 cột từ cột B(B C) còn cột D thì copy đến cột E ạ
Bài đã được tự động gộp:


Bạn xem sheet ạ.
Nhấp chuột vào đây để mở rộng...
Thử code sau:
Mã: 
Sub Copy_DieuKien()
Dim DongCuoi As Long
Dim DieuKien As String
Sheet2.Range("B7").CurrentRegion.Offset(1).Clear
Sheet3.Range("B7").CurrentRegion.Offset(1).Clear
    With Sheet1
        DongCuoi = .Cells(Rows.Count, 1).End(xlUp).Row
        DieuKien = .Range("N6").Value
        .Range("A4").AutoFilter Field:=5, Criteria1:=DieuKien
        .Range("B5:D" & DongCuoi).Copy Sheet2.Range("B8")
        .Range("A4").AutoFilter Field:=5, Criteria1:="<>" & DieuKien
        .Range("B5:C" & DongCuoi).Copy Sheet3.Range("B8")
        .Range("E5:E" & DongCuoi).Copy Sheet3.Range("D8")
        .Range("D5:D" & DongCuoi).Copy Sheet3.Range("E8")
        .Range("B4").AutoFilter
    End With
End Sub
 

File đính kèm

  • Copy dong.new.xlsm
    20.5 KB · Đọc: 9
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

H
  • Question
Code subtotal và tìm điều kiện
Trả lời
4
Đọc
49
DeTong
D
P
  • Question
Nhờ hỗ trợ chọn vùng trong Inputbox ở VBA
Trả lời
13
Đọc
420
Hoàng Tuấn 868
H
H
Xin giúp đỡ lấy lại file excel bị lưu đè
Trả lời
2
Đọc
37
HOANGVO797969
H
kiencuong030184
  • Question
ẩn hiện dòng, cột có điều kiên
Trả lời
3
Đọc
57
SA_DQ
SA_DQ
Emyeuexcel
  • Question
In theo số thứ tự
    • Chấp nhận
Trả lời
6
Đọc
122
Emyeuexcel
Emyeuexcel
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