[Nhờ Giúp] Nhờ mọi người hướng dẫn làm Code gọn.

[hungtin1997]

Em là thành viên mới.
Tình hình là em có mò VBA được vài tuần. Tra google này nọ thì có tự viết được 1 file theo yêu cầu của bản thân và công việc.
Cụ thể như sau:
- Tạo 1 dãy ô liên tiếp trong 1 cột dựa trên 1 vùng dữ liệu cho trước.
- Dãy ô được tạo có số lần lặp lại của dữ liệu gốc và có 2 cách sắp xếp:

1. Giống như việc copy vùng dữ liệu gốc dán liên tiếp vào cuối cột theo n lần cho trước.​

2. 1 ô trong dữ liệu gốc được lặp lại n lần, tiếp theo ô thứ 2 trong dữ liệu gốc cũng n lần, cứ thế tới hết ô trong dữ liệu nguồn. Tất nhiên là vẫn theo 1 cột nối dài.​

Em đã tạo thành công và em phát hiện rằng copy dán n lần thì file chạy khá chậm. Em sử dụng cách cho biến chạy đến ô nhất định thì dữ liệu bằng ô nhất định trong dữ liệu nguồn.
Xong, vì mới nên nhìn lại code khá rối. Với lại mong các anh/chị đóng góp ý kiến về cách viết sao cho trực quang, khi nhìn lại dễ nhớ cách mình đã làm và giúp code gọn hơn, chạy nhanh hơn.
Ps: Sẵn tiện chia sẽ luôn nếu bạn nào đang cần vụ này

 

[xuongrongdat]

@hungtin1997 : trước khi tiếp tục bạn nên sửa lại nội dung tiêu đề và cả bên trong bài viết bạn ơi. Những từ tiếng Anh bạn cứ dịch và ghi rõ ra là tiếng Việt đi nhen, phạm quy đó: help, Pro, mem, share,...??? Trong diễn đàn có rất nhiều bác nhiều anh giỏi Excel và VBA nhưng họ không hiểu bạn viết tiếng Anh hay viết tắt nghĩa là gì đâu!!!

Thân.

 

[vu_tuan_manh_linh]

Bạn tham khảo một cách làm khác

Sub tao_loop()
Application.ScreenUpdating = False
Columns("B:C").ClearContents
Dim i, Solan, SoDL, Tong, Idx
Dim App
Set App = Application.WorksheetFunction
Solan = Cells(1, 4).Value
SoDL = App.CountA(Range("A:A"))
Tong = Solan * SoDL
For i = 1 To Tong
    Idx = ((i - 1) Mod SoDL) + 1
    Cells(i, 2).Value = Cells(Idx, 1).Value
    Idx = Int((i - 1) / Solan) + 1
    Cells(i, 3).Value = Cells(Idx, 1).Value
Next i
Application.ScreenUpdating = True
End Sub

 

[hungtin1997]

Bạn tham khảo một cách làm khác

Sub tao_loop()
Application.ScreenUpdating = False
Columns("B:C").ClearContents
Dim i, Solan, SoDL, Tong, Idx
Dim App
Set App = Application.WorksheetFunction
Solan = Cells(1, 4).Value
SoDL = App.CountA(Range("A:A"))
Tong = Solan * SoDL
For i = 1 To Tong
    Idx = ((i - 1) Mod SoDL) + 1
    Cells(i, 2).Value = Cells(Idx, 1).Value
    Idx = Int((i - 1) / Solan) + 1
    Cells(i, 3).Value = Cells(Idx, 1).Value
Next i
Application.ScreenUpdating = True
End Sub

Cảm ơn bác rất nhiều, code rất gọn ràng. Tuy nhiên em chưa hiểu lắm phần Idx, bác giải thích 1 tí cho em thông suốt với ạ.

 

[PacificPR]

Bạn tham khảo thử xem: Oánh 1000 lần thử nhé

Sub tao_loop()
    Dim sArr, dArr, i As Long, N As Integer
    Dim Idx As Long, Idx1 As Long, K As Long, K1 As Long
    Dim R As Long, C As Long, Rs As Long
    N = Range("D1").Value:    Rs = Rows.Count
    sArr = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
    If N > 0 Then
        R = UBound(sArr) * N: C = 2
        If R > Rs Then Exit Sub
    Else
        Exit Sub
    End If
    ReDim dArr(1 To R, 1 To C)
    For Idx = 1 To N
        For i = 1 To UBound(sArr)
            K = K + 1
            dArr(K, 1) = sArr(i, 1)
            If K1 + 1 <= UBound(dArr) Then
                For Idx1 = 1 To N
                    K1 = K1 + 1
                    dArr(K1, 2) = sArr(i, 1)
                Next Idx1
            End If
        Next i
    Next Idx
    Range("B1", Range("B" & Rows.Count).End(xlUp)).Resize(, 2).ClearContents
    Range("B1").Resize(R, C) = dArr
End Sub

 

[hungtin1997]

Bạn tham khảo thử xem: Oánh 1000 lần thử nhé

Sub tao_loop()
    Dim sArr, dArr, i As Long, N As Integer
    Dim Idx As Long, Idx1 As Long, K As Long, K1 As Long
    Dim R As Long, C As Long, Rs As Long
    N = Range("D1").Value:    Rs = Rows.Count
    sArr = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
    If N > 0 Then
        R = UBound(sArr) * N: C = 2
        If R > Rs Then Exit Sub
    Else
        Exit Sub
    End If
    ReDim dArr(1 To R, 1 To C)
    For Idx = 1 To N
        For i = 1 To UBound(sArr)
            K = K + 1
            dArr(K, 1) = sArr(i, 1)
            If K1 + 1 <= UBound(dArr) Then
                For Idx1 = 1 To N
                    K1 = K1 + 1
                    dArr(K1, 2) = sArr(i, 1)
                Next Idx1
            End If
        Next i
    Next Idx
    Range("B1", Range("B" & Rows.Count).End(xlUp)).Resize(, 2).ClearContents
    Range("B1").Resize(R, C) = dArr
End Sub

Cám ơn bác, code cũng rất nhanh nhưng em nhìn mãi chẳng hiểu. Một lần nữa, cảm ơn

 

[vu_tuan_manh_linh]

Cảm ơn bác rất nhiều, code rất gọn ràng. Tuy nhiên em chưa hiểu lắm phần Idx, bác giải thích 1 tí cho em thông suốt với ạ.

Chỉ đơn giản là tại vị trí "i" thì cần lấy dữ liệu tại dòng idx cột A.

 

[PacificPR]

Cám ơn bác, code cũng rất nhanh nhưng em nhìn mãi chẳng hiểu. Một lần nữa, cảm ơn

Bạn ngồi thêm 3 ngày nữa trên GPE nữa là viết ra cái Code còn nhanh hơn của mình nhiều

 

[hungtin1997]

Bạn tham khảo một cách làm khác

Sub tao_loop()
Application.ScreenUpdating = False
Columns("B:C").ClearContents
Dim i, Solan, SoDL, Tong, Idx
Dim App
Set App = Application.WorksheetFunction
Solan = Cells(1, 4).Value
SoDL = App.CountA(Range("A:A"))
Tong = Solan * SoDL
For i = 1 To Tong
    Idx = ((i - 1) Mod SoDL) + 1
    Cells(i, 2).Value = Cells(Idx, 1).Value
    Idx = Int((i - 1) / Solan) + 1
    Cells(i, 3).Value = Cells(Idx, 1).Value
Next i
Application.ScreenUpdating = True
End Sub

À em ngẫm ra rồi, thêm 1 biến nhưng giải quyết được rất nhiều vấn đề, cảm ơn bác!

 

[Nhattanktnn]

Hoặc góp vui tí:

Sub B()
Dim aRng As Range, bRng As Range, cRng As Range
Application.ScreenUpdating = False
Set aRng = Range("A1:A" & Range("A1").End(xlDown).Row)
Set bRng = aRng.Offset(, 1).Resize(aRng.Rows.Count * [D1])
Set cRng = bRng.Offset(, 1)
aRng.Copy Union(bRng, cRng)
cRng.Sort Key1:=cRng(1, 1), Header:=xlNo
Application.ScreenUpdating = True
End Sub

 

[huuthang_bd]

Hoặc góp vui tí:

Sub B()
Dim aRng As Range, bRng As Range, cRng As Range
Application.ScreenUpdating = False
Set aRng = Range("A1:A" & Range("A1").End(xlDown).Row)
Set bRng = aRng.Offset(, 1).Resize(aRng.Rows.Count * [D1])
Set cRng = bRng.Offset(, 1)
aRng.Copy Union(bRng, cRng)
cRng.Sort Key1:=cRng(1, 1), Header:=xlNo
Application.ScreenUpdating = True
End Sub

Sort sẽ làm thay đổi vị trí so với dữ liệu gốc.

Sub ABC()
Dim Arr As Variant, Result As Variant, Times As Long, x As Long, i As Long, j As Long
Arr = Range("A1:A6").Value
Times = Range("D1").Value
ReDim Result(1 To UBound(Arr, 1) * Times, 1 To 1)
For i = 1 To UBound(Arr, 1)
    x = (i - 1) * Times
    For j = 1 To Times
        Result(x + j, 1) = Arr(i, 1)
    Next
Next
Range("C1").Resize(UBound(Result, 1)).Value = Result
End Sub

 

[Nhattanktnn]

Sort sẽ làm thay đổi vị trí so với dữ liệu gốc.

Bác nói chi tiết hơn được không? Em sort mỗi cRng thì thay đổi vị trí là như nào ạ

 

[hungtin1997]

Sort sẽ làm thay đổi vị trí so với dữ liệu gốc.

Đúng vậy ạ
Gõ thử dữ liệu gốc có dạng text thì kết quả ở cột C bị ngược thứ tự.

 

[befaint]

cột C2

Không có cột nào tên là C2.

 

[hungtin1997]

Không có cột nào tên là C2.

Sửa không kịp với bác luôn

 

[huuthang_bd]

Bác nói chi tiết hơn được không? Em sort mỗi cRng thì thay đổi vị trí là như nào ạ

Xem bài #13 nhé.