Dò tìm số theo cột và chèn số dòng theo số tại ô tìm được

[anh79_ct]

Chào anh chị, mình có bảng dữ liệu bên trái, ở cột thứ 3 từ trên xuống có số hoặc chữ. Mình muốn dò tìm từ trên xuống theo cột 3, nếu thấy số thì chèn số dòng tương ứng với số trong ô, và đồng thời copy nội dung cùng dòng tại cột 2 sang cột 1 như hình bên phải. Số lượng dòng dữ liệu lên đến khoảng 65.000 dòng. Mình gởi file mẫu kèm theo

Mong mọi người giúp mình nhé!

 

[PacificPR]

Chào anh chị, mình có bảng dữ liệu bên trái, ở cột thứ 3 từ trên xuống có số hoặc chữ. Mình muốn dò tìm từ trên xuống theo cột 3, nếu thấy số thì chèn số dòng tương ứng với số trong ô, và đồng thời copy nội dung cùng dòng tại cột 2 sang cột 1 như hình bên phải. Số lượng dòng dữ liệu lên đến khoảng 65.000 dòng. Mình gởi file mẫu kèm theo

Mong mọi người giúp mình nhé!

Bạn tham khảo thử

Sub InsertRow()
    Dim sArr(), dArr(1 To 65535, 1 To 3)
    Dim LastRow As Long, I As Long, J As Long, K As Long, Idx As Long
With Sheet1
    LastRow = .Range("A" & Rows.Count).End(xlUp).Row
    If LastRow > 5 Then
        sArr = .Range("A6:C" & LastRow).Value
        For I = 1 To UBound(sArr, 1)
            K = K + 1
            For J = 1 To UBound(sArr, 2)
                dArr(K, J) = sArr(I, J)
            Next J
            If IsNumeric(sArr(I, 3)) Then
                For Idx = 1 To sArr(I, 3)
                    K = K + 1
                    dArr(K, 1) = sArr(I, 2)
                Next Idx
            End If
        Next I
        .Range("F6").Resize(K, 3) = dArr
    End If
End With
End Sub

 

[Phuocam]

Góp vui,

Sub Macro1()
Dim i As Long, temp As Variant
For i = Range("C" & Rows.Count).End(xlUp).Row To 6 Step -1
    temp = (Range("C" & i).Value)
    If IsNumeric(temp) Then
        Range("A" & i).Offset(1).Resize(temp, 3).Insert Shift:=xlDown
        Range("A" & i).Offset(1).Resize(temp, 1).Value = Range("B" & i).Value
    End If
Next
End Sub

 

[anh79_ct]

Cám ơn 2 bạn đã giúp đỡ! Code của bạn phuocam chạy tốt, còn không hiểu sao của bạn PacificPR lại không chạy.

 

[anh79_ct]

Góp vui,

Sub Macro1()
Dim i As Long, temp As Variant
For i = Range("C" & Rows.Count).End(xlUp).Row To 6 Step -1
    temp = (Range("C" & i).Value)
    If IsNumeric(temp) Then
        Range("A" & i).Offset(1).Resize(temp, 3).Insert Shift:=xlDown
        Range("A" & i).Offset(1).Resize(temp, 1).Value = Range("B" & i).Value
    End If
Next
End Sub

Bạn puocam cho mình hỏi, nếu dữ liệu của mình có số 0 thì code báo lỗi, nhờ bạn chỉnh giúp dùm nhé. Nếu gặp số 0 thì bỏ qua, không chèn thêm dòng.

 

[Phuocam]

Thêm bẫy lỗi vào, như: If temp > 0 Then ...

Sub Macro1()
Dim i As Long, temp As Variant
For i = Range("C" & Rows.Count).End(xlUp).Row To 6 Step -1
    temp = (Range("C" & i).Value)
    If IsNumeric(temp) Then
        If temp > 0 Then 'Thêm dòng này
            Range("A" & i).Offset(1).Resize(temp, 3).Insert Shift:=xlDown
            Range("A" & i).Offset(1).Resize(temp, 1).Value = Range("B" & i).Value
        End If 'Thêm dòng này
    End If
Next
End Sub

 

[SA_DQ]

Sub ThemDongTheoSoLieuChoTruoc()
Dim WF As Object, Arr()
Dim J As Long, W As Long, Cot As Integer
Dim GPE As String

Set WF = Application.WorksheetFunction
With Sheet1
    Arr() = .[B6].CurrentRegion.Offset(1).Value
    W = WF.Sum(.[C6].Resize(UBound(Arr())))
    ReDim dArr(1 To UBound(Arr()) + 9 + W, 1 To 3)
    W = 0
    For J = 1 To UBound(Arr())
        W = W + 1:                      GPE = Arr(J, 2)
        For Cot = 1 To 3
            dArr(W, Cot) = Arr(J, Cot)
        Next Cot
        If IsNumeric(Arr(J, 3)) And Arr(J, 3) > 0 Then
            For Cot = 1 To Arr(J, 3)
                W = W + 1:              dArr(W, 1) = GPE
            Next Cot
        End If
    Next J
    .[F6].Resize(W, 3).Value = dArr()
End With
End Sub

Sẽ tăng tốc chăng?