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

hungtin1997 · 16/10/20

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 · 16/10/20

@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 · 16/10/20

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

PHP:

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 · 16/10/20

vu_tuan_manh_linh đã viết:

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

PHP:

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 · 16/10/20

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

Mã:

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 · 16/10/20

PacificPR đã viết:

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

Mã:

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 · 16/10/20

hungtin1997 đã viết:
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 · 16/10/20

hungtin1997 đã viết:
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 · 16/10/20

vu_tuan_manh_linh đã viết:

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

PHP:

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 · 16/10/20

Hoặc góp vui tí:

PHP:

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 · 16/10/20

Nhattanktnn đã viết:

Hoặc góp vui tí:

PHP:

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.

Mã:

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 · 16/10/20

huuthang_bd đã viết:
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 · 16/10/20

huuthang_bd đã viết:
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 · 16/10/20

hungtin1997 đã viết:
cột C2

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

hungtin1997 · 16/10/20

befaint đã viết:
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 · 16/10/20

Nhattanktnn đã viết:
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é.

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

hungtin1997

Dậm chân tại chỗ là đi lùi

File đính kèm

xuongrongdat

Có bao giờ bạn tự hỏi "Tôi là ai?"

vu_tuan_manh_linh

linhvtm84@gmail.com

hungtin1997

Dậm chân tại chỗ là đi lùi

PacificPR

Thành viên mới

hungtin1997

Dậm chân tại chỗ là đi lùi

vu_tuan_manh_linh

linhvtm84@gmail.com

PacificPR

Thành viên mới

hungtin1997

Dậm chân tại chỗ là đi lùi

Nhattanktnn

Thành viên gắn bó

huuthang_bd

Chuyên gia GPE

Nhattanktnn

Thành viên gắn bó

hungtin1997

Dậm chân tại chỗ là đi lùi

befaint

|||||||||||||

hungtin1997

Dậm chân tại chỗ là đi lùi

huuthang_bd

Chuyên gia GPE

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

Facebook

Group

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