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

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
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

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

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

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 Question
Tô đậm tiêu đề cho cho các sheet (1 người xem)
Trả lời
4
Đọc
110
hieu998
H
GPE-Trợ Lý
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM (1 người xem)
    • Thích
Trả lời
1
Đọc
846
GPE-Trợ Lý
GPE-Trợ Lý
Z
TRỢ GIÚP K SORT ĐƯỢC THỨ TỰ NGÀY THÁNG NĂM TRONG EXCEL
Trả lời
2
Đọc
39
Duy Tùng 9x
Duy Tùng 9x
H
Tách file nguồn thành nhiều file dựa vào điều kiện (2 người xem)
Trả lời
5
Đọc
94
LePhatHuy
LePhatHuy
D
Nhờ trợ giúp xác định thứ tự của các từ và cụm từ trong 1 chuỗi văn bản.
Trả lời
9
Đọc
179
duongbabao90
D
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
7
Đọc
322
fujishima
F
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (1 người xem)
    • Thích
2 3
Trả lời
49
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
tính thể tích bồn dầu hình trụ elip nằm ngang (1 người xem)
Trả lời
10
Đọc
47K
pvkiem
P
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
18
Đọc
388
tle2003
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
14
Đọc
2K
GPE-Trợ Lý
GPE-Trợ Lý
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ
Trả lời
17
Đọc
496
VetMini
V
G
Xin Code xóa Module.
Trả lời
10
Đọc
423
GCQ
G
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
348
Đọc
31K
ongke0711
ongke0711
D
  • Đã giải quyết
Quản lý email outlook qua VBA cần giúp đỡ
2
Trả lời
23
Đọc
760
nguyendang95
N
G
Tách công thức ra khỏi chuỗi và tính kết quả?
2
Trả lời
26
Đọc
2K
thuytrangbp28
T
thlpro
Cách lập Công thức tính số ngày nghỉ AL, ưu tiên tính 2024 trước rồi mới tính 2025
Trả lời
8
Đọc
214
bebo021999
B
N
Hàm tăng số đếm theo điều kiện
Trả lời
4
Đọc
125
bebo021999
B
M
Xin giúp đỡ làm công thức điều kiện
    • Yêu thích
Trả lời
3
Đọc
175
tayGa
T
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính (1 người xem)
    • Thích
Trả lời
2
Đọc
263
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table
Trả lời
5
Đọc
221
DeTong
D
Xem thêm…

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

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom