copy dạng vòng lặp đi lặp lại các dòng không trùng nhau

Uyennamph · 4/6/21

Chào mọi người, xin mọi người ai biết giúp em xem có cách viết code nào nhanh và đỡ bị giật không với ạ. E có một dạng dữ liệu ở sheet1. em muốn copy sang sheet2 với điều kiện lặp ( kiểu ví dụ nên em làm ít, nếu dạng lặp đi lặp lặp giữa các dòng sao cho không trùng nhau), code của em dài dòng, khi chạy code bị nháy màn hình nhiều.... em mong mọi người ai biết giúp đỡ cách nhanh nhất với ạ

HieuCD · 4/6/21

Uyennamph đã viết:
Chào mọi người, xin mọi người ai biết giúp em xem có cách viết code nào nhanh và đỡ bị giật không với ạ. E có một dạng dữ liệu ở sheet1. em muốn copy sang sheet2 với điều kiện lặp ( kiểu ví dụ nên em làm ít, nếu dạng lặp đi lặp lặp giữa các dòng sao cho không trùng nhau), code của em dài dòng, khi chạy code bị nháy màn hình nhiều.... em mong mọi người ai biết giúp đỡ cách nhanh nhất với ạ

Chạy code

Mã:

Sub ABC()
  Dim eRow As Long, pasteRow As Long, i As Long
  With Sheets("Sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi sheet1
    If eRow < 4 Then Exit Sub 'Khong co du lieu thoat sub
    pasteRow = 3 'dong Paste du lieu dau tien o sheet2
    Application.ScreenUpdating = False 'Khong cap nhat ket qua len man hinh
    For i = 4 To eRow
      .Rows("3").Copy Sheets("Sheet2").Rows(pasteRow) 'Copy dong 3
      .Rows(i).Copy Sheets("Sheet2").Rows(pasteRow + 1) 'Copy dong 4, 5 ...
      pasteRow = pasteRow + 3
    Next i
    Application.ScreenUpdating = True 'Cap nhat ket qua len man hinh
  End With
End Sub

SA_DQ · 5/6/21

Mình xin hỏi chủ bài đăng là:
Sau dòng A & Z thì đến là gì? Có phải;

. . . .
A
Y

A
Z

B
A

B
C

. . . . .

Nếu đúng như mình mường tượng thì thử với con ni:

PHP:

Sub GPE_3Dong()
 Const Alf As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 Dim J As Long, W As Long, Z As Long, I As Long
 ReDim Arr(1 To 36 * 36 * 6, 1 To 1) As String
 
 For J = 1 To Len(Alf)
    For I = 1 To Len(Alf)
        If Mid(Alf, J, 1) <> Mid(Alf, I, 1) Then
            W = W + 1:              Arr(W, 1) = Mid(Alf, J, 1)
            W = W + 1:              Arr(W, 1) = Mid(Alf, I, 1)
            W = W + 1
        End If
    Next I
 Next J
 Sheet2.[B1].Resize(W).Value = Arr()
End Sub

Nhattanktnn · 5/6/21

SA_DQ đã viết:
Mình xin hỏi chủ bài đăng là:
Sau dòng A & Z thì đến là gì? Có phải;

. . . .
A
Y
A
Z
B
A
B
C

. . . . .

Nếu đúng như mình mường tượng thì thử với con ni:

PHP:

Sub GPE_3Dong() Const Alf As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" Dim J As Long, W As Long, Z As Long, I As Long ReDim Arr(1 To 36 * 36 * 6, 1 To 1) As String For J = 1 To Len(Alf) For I = 1 To Len(Alf) If Mid(Alf, J, 1) <> Mid(Alf, I, 1) Then W = W + 1: Arr(W, 1) = Mid(Alf, J, 1) W = W + 1: Arr(W, 1) = Mid(Alf, I, 1) W = W + 1 End If Next I Next J Sheet2.[B1].Resize(W).Value = Arr() End Sub

Nhưng ABC chắc là ví dụ thôi bác nhỉ, dữ liệu thật có khi không phải vậy

SA_DQ · 5/6/21

Nhattanktnn đã viết:
Nhưng ABC chắc là ví dụ thôi bác nhỉ, dữ liệu thật có khi không phải vậy

Nếu là vậy thì tiến hành thêm động tác tra như tra từ từ điển nữa thôi.

Uyennamph · 5/6/21

HieuCD đã viết:

Chạy code

Mã:

Sub ABC()
  Dim eRow As Long, pasteRow As Long, i As Long
  With Sheets("Sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi sheet1
    If eRow < 4 Then Exit Sub 'Khong co du lieu thoat sub
    pasteRow = 3 'dong Paste du lieu dau tien o sheet2
    Application.ScreenUpdating = False 'Khong cap nhat ket qua len man hinh
    For i = 4 To eRow
      .Rows("3").Copy Sheets("Sheet2").Rows(pasteRow) 'Copy dong 3
      .Rows(i).Copy Sheets("Sheet2").Rows(pasteRow + 1) 'Copy dong 4, 5 ...
      pasteRow = pasteRow + 3
    Next i
    Application.ScreenUpdating = True 'Cap nhat ket qua len man hinh
  End With
End Sub

Dạ em xin chân thành cảm ơn ạ. Code trên là copy các dòng từ dòng đầu tiên ghép với các dòng tiếp theo ( đấy là một lượt ) Hết dòng A thì ghép tiếp dòng B cũng tương tự A, hết dòng B thì đến tiếp dòng C.... cho đến hết luôn thì làm thế nào ạ? Anh Chị làm ơn giúp em viết tiếp với ạ

Bài đã được tự động gộp: 5/6/21

SA_DQ đã viết:
Mình xin hỏi chủ bài đăng là:
Sau dòng A & Z thì đến là gì? Có phải;

. . . .
A
Y
A
Z
B
A
B
C

. . . . .

Nếu đúng như mình mường tượng thì thử với con ni:

PHP:

Sub GPE_3Dong() Const Alf As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" Dim J As Long, W As Long, Z As Long, I As Long ReDim Arr(1 To 36 * 36 * 6, 1 To 1) As String For J = 1 To Len(Alf) For I = 1 To Len(Alf) If Mid(Alf, J, 1) <> Mid(Alf, I, 1) Then W = W + 1: Arr(W, 1) = Mid(Alf, J, 1) W = W + 1: Arr(W, 1) = Mid(Alf, I, 1) W = W + 1 End If Next I Next J Sheet2.[B1].Resize(W).Value = Arr() End Sub

dạ em xin chân thành cảm ơn ạ, nhưng e muốn copy hết cả dòng ghép lần lượt với các dòng phía sau, và cứ lặp đi lặp lại cho đến hết.... AB, AC, AD... hết lượt thì đến BA, BC, BD... cho đến hết vòng luôn ạ

SA_DQ · 5/6/21

(/ậy bạn đã cho macro ở #03 đưa cho bạn kết quả chưa vậy?

Z

S

Z

T

Z

U

Z

V

Z

W

Z

X

Z

Y

1950

3888

HieuCD · 5/6/21

Uyennamph đã viết:
Dạ em xin chân thành cảm ơn ạ. Code trên là copy các dòng từ dòng đầu tiên ghép với các dòng tiếp theo ( đấy là một lượt ) Hết dòng A thì ghép tiếp dòng B cũng tương tự A, hết dòng B thì đến tiếp dòng C.... cho đến hết luôn thì làm thế nào ạ? Anh Chị làm ơn giúp em viết tiếp với ạ

Bài đã được tự động gộp: 5/6/21

dạ em xin chân thành cảm ơn ạ, nhưng e muốn copy hết cả dòng ghép lần lượt với các dòng phía sau, và cứ lặp đi lặp lại cho đến hết.... AB, AC, AD... hết lượt thì đến BA, BC, BD... cho đến hết vòng luôn ạ

Bạn chạy các code bài #2 và #3 chưa?

Phuocam · 6/6/21

Uyennamph đã viết:
Dạ em xin chân thành cảm ơn ạ. Code trên là copy các dòng từ dòng đầu tiên ghép với các dòng tiếp theo ( đấy là một lượt ) Hết dòng A thì ghép tiếp dòng B cũng tương tự A, hết dòng B thì đến tiếp dòng C.... cho đến hết luôn thì làm thế nào ạ? Anh Chị làm ơn giúp em viết tiếp với ạ

Bài đã được tự động gộp: 5/6/21

dạ em xin chân thành cảm ơn ạ, nhưng e muốn copy hết cả dòng ghép lần lượt với các dòng phía sau, và cứ lặp đi lặp lại cho đến hết.... AB, AC, AD... hết lượt thì đến BA, BC, BD... cho đến hết vòng luôn ạ

Bạn thêm 1 vòng For nữa vào code của anh @HieuCD :

Mã:

Sub Combine()
  Dim eRow As Long, pasteRow As Long, i As Long, J As Long
  With Sheets("Sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi sheet1
    If eRow < 4 Then Exit Sub 'Khong co du lieu thoat sub
    pasteRow = 3 'dong Paste du lieu dau tien o sheet2
    Application.ScreenUpdating = False 'Khong cap nhat ket qua len man hinh
    For J = 4 To eRow - 1
        For i = 4 To eRow
            If i <> J Then
                .Rows(J).Copy Sheets("Sheet2").Rows(pasteRow) 'Copy dong 3
                .Rows(i).Copy Sheets("Sheet2").Rows(pasteRow + 1) 'Copy dong 4, 5 ...
                pasteRow = pasteRow + 3
            End If
        Next i
    Next J
    Application.ScreenUpdating = True 'Cap nhat ket qua len man hinh
  End With
End Sub

Uyennamph · 6/6/21

phuocam đã viết:

Bạn thêm 1 vòng For nữa vào code của anh @HieuCD :

Mã:

Sub Combine()
  Dim eRow As Long, pasteRow As Long, i As Long, J As Long
  With Sheets("Sheet1")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row 'Dong cuoi sheet1
    If eRow < 4 Then Exit Sub 'Khong co du lieu thoat sub
    pasteRow = 3 'dong Paste du lieu dau tien o sheet2
    Application.ScreenUpdating = False 'Khong cap nhat ket qua len man hinh
    For J = 4 To eRow - 1
        For i = 4 To eRow
            If i <> J Then
                .Rows(J).Copy Sheets("Sheet2").Rows(pasteRow) 'Copy dong 3
                .Rows(i).Copy Sheets("Sheet2").Rows(pasteRow + 1) 'Copy dong 4, 5 ...
                pasteRow = pasteRow + 3
            End If
        Next i
    Next J
    Application.ScreenUpdating = True 'Cap nhat ket qua len man hinh
  End With
End Sub

Dạ em xin chân thành cảm ơn ạ. file của em đã xử lý đúng theo mong muốn nhờ @HieuCD thêm vòng lặp for như Phuocam nói rồi ạ
Thật thuận tiện với VBA. Cảm ơn mọi người đã giúp đỡ. chúc mọi người ngày cuối tuần vui vẻ ạ

Bài đã được tự động gộp: 6/6/21

HieuCD đã viết:
Bạn chạy các code bài #2 và #3 chưa?

Code bài #2 và #3 chưa như em mong muốn. Dạ em xin chân thành cảm ơn ạ. file của em đã xử lý đúng theo mong muốn nhờ Anh @HieuCD thêm vòng lặp for như Phuocam nói rồi ạ
Thật thuận tiện với VBA. Cảm ơn mọi người đã giúp đỡ. chúc mọi người ngày cuối tuần vui vẻ ạ

copy dạng vòng lặp đi lặp lại các dòng không trùng nhau

Uyennamph

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

SA_DQ

/(hông là gì!

Nhattanktnn

Thành viên gắn bó

SA_DQ

/(hông là gì!

Uyennamph

Thành viên mới

SA_DQ

/(hông là gì!

HieuCD

Chuyên gia GPE

Phuocam

Thành viên mới

Uyennamph

Thành viên mới

Bài viết mới nhất

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