Help! Chèn bổ sung các row giống nhau

[hvt42000]

K/g các pro

Nhờ anh chị xem giúp file có thể có đoạn code nào để chạy tự động bổ sung các row giống như 1.1 đến 1.10 không ah
vì số lượng nhiều mà Insert manual thì lâu quá

Tks all

 

[lehuong1409]

K/g các pro

Nhờ anh chị xem giúp file có thể có đoạn code nào để chạy tự động bổ sung các row giống như 1.1 đến 1.10 không ah
vì số lượng nhiều mà Insert manual thì lâu quá

Tks all

VBA thì mình chưa nghĩ ra cách đánh số thứ tự nên bạn dùng thử file bán thủ công này nhé. Hiện mình vẫn dùng cách này cho vài file của mình

 

[BuiQuangThuan]

Bạn sửa tiêu đề và các từ viết tắt. Mình gửi code lên liền

 

[snow25]

K/g các pro

Nhờ anh chị xem giúp file có thể có đoạn code nào để chạy tự động bổ sung các row giống như 1.1 đến 1.10 không ah
vì số lượng nhiều mà Insert manual thì lâu quá

Tks all

Hên sui.

Sub abc()
   Dim i As Long, lr As Long, arr, kq() As String, data, a As Long, j As Long
   With Sheet1
        lr = .Range("A" & Rows.Count).End(xlUp).Row + 1
        arr = .Range("A15:C" & lr).Value
        data = .Range("B5:C14").Value
        ReDim kq(1 To UBound(arr) * 12, 1 To 3)
        For i = 1 To UBound(arr) - 1
               a = a + 1
               kq(a, 1) = UCase(arr(i, 1))
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
            If Len(arr(i, 1)) > 0 And Len(arr(i + 1, 1)) > 0 Then
               For j = 1 To 10
                   a = a + 1
                   kq(a, 2) = data(j, 1)
                   kq(a, 3) = data(j, 2)
               Next j
            End If
      Next i
            If Len(arr(i - 2, 1)) > 0 Then
                For j = 1 To 10
                   a = a + 1
                   kq(a, 2) = data(j, 1)
                   kq(a, 3) = data(j, 2)
               Next j
            End If
      .Range("D15:F15").Resize(a).Value = kq
  End With
End Sub

 

[Nhattanktnn]

Hên sui.

Sub abc()
   Dim i As Long, lr As Long, arr, kq() As String, data, a As Long, j As Long
   With Sheet1
        lr = .Range("A" & Rows.Count).End(xlUp).Row + 1
        arr = .Range("A15:C" & lr).Value
        data = .Range("B5:C14").Value
        ReDim kq(1 To UBound(arr) * 12, 1 To 3)
        For i = 1 To UBound(arr) - 1
               a = a + 1
               kq(a, 1) = UCase(arr(i, 1))
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 3)
            If Len(arr(i, 1)) > 0 And Len(arr(i + 1, 1)) > 0 Then
               For j = 1 To 10
                   a = a + 1
                   kq(a, 2) = data(j, 1)
                   kq(a, 3) = data(j, 2)
               Next j
            End If
      Next i
            If Len(arr(i - 2, 1)) > 0 Then
                For j = 1 To 10
                   a = a + 1
                   kq(a, 2) = data(j, 1)
                   kq(a, 3) = data(j, 2)
               Next j
            End If
      .Range("D15:F15").Resize(a).Value = kq
  End With
End Sub

Sao thấy code nó dư dư bác nhỉ?
Sao lr phải cộng thêm 1 và sao phải xét Len(arr(i + 1, 1)) > 0?
Dòng kq là UBound(arr) * 11 chứ?
Phần này có thể gộp vào phía trên mà

If Len(arr(i - 2, 1)) > 0 Then
For j = 1 To 10
a = a + 1
kq(a, 2) = data(j, 1)
kq(a, 3) = data(j, 2)
Next j
End If

 

[VetMini]

Hên sui.
...

Pơ rô ghê đi. Xứng đáng thưởng vài cái tê ca ét.

Nhưng mà hinh như tiêu đề bài này dùng "heo" là phạm quy.

 

[snow25]

Sao thấy code nó dư dư bác nhỉ?
Sao lr phải cộng thêm 1 và sao phải xét Len(arr(i + 1, 1)) > 0?
Dòng kq là UBound(arr) * 11 chứ?
Phần này có thể gộp vào phía trên mà

Thực ra code nó đã viết đè vào data rồi thì phải tính thêm mấy trường hợp nữa.