Chèn dòng tự động trong excel (1 người xem)

[thanhtam_thanhtam]

Chào mọi người,
Mình đang mất khá nhiều thời gian để lặp lại các thao tác manual, giống nhau, nên rất mong nhận được sự giúp đỡ của mọi người.
Vấn đề của mình đó là:
1/ Mình đang xử lý các tờ khai
2/ Các tờ khai sẽ có tờ khai nhánh và được đánh số thứ tự là 1,2,3....
3/ Mình cần phải gom các tờ khai có nhánh vào 1 dòng, vị trí của dòng chính là dòng được chèn (chèn vào dòng sau dòng có số thứ tự nhánh lớn nhất)
Do khá khó hình dung nên mình đính kèm file, nhờ mọi người xem và advise giùm mình nhé.
Mình cám ơn rất nhiều.

 

[snow25]

Chào mọi người,
Mình đang mất khá nhiều thời gian để lặp lại các thao tác manual, giống nhau, nên rất mong nhận được sự giúp đỡ của mọi người.
Vấn đề của mình đó là:
1/ Mình đang xử lý các tờ khai
2/ Các tờ khai sẽ có tờ khai nhánh và được đánh số thứ tự là 1,2,3....
3/ Mình cần phải gom các tờ khai có nhánh vào 1 dòng, vị trí của dòng chính là dòng được chèn (chèn vào dòng sau dòng có số thứ tự nhánh lớn nhất)
Do khá khó hình dung nên mình đính kèm file, nhờ mọi người xem và advise giùm mình nhé.
Mình cám ơn rất nhiều.

View attachment 226474

Hàm mình không biết.Có thể dùng VBA.

 

[thanhtam_thanhtam]

Hàm mình không biết.Có thể dùng VBA.

Vậy thì quá tuyệt ạ, bạn có thể viết gửi giùm mình không. Cám ơn bạn rất nhiều,

 

[snow25]

Vậy thì quá tuyệt ạ, bạn có thể viết gửi giùm mình không. Cám ơn bạn rất nhiều,

Bạn thử.Chắc vẫn còn sót vài trường hợp.

Sub chuyendulieu()
Application.ScreenUpdating = False
    Dim arr, a As Long, lr As Long, i As Long, kq, gop As String, b As Long, j As Long, c As Long
    With Sheets("Record")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         arr = .Range("A5:D" & lr).Value
         ReDim kq(1 To UBound(arr) + 1000, 1 To 4)
                For j = 1 To 4
                    kq(1, j) = arr(1, j)
                Next j
         b = arr(1, 3)
         a = 1
         If b = 1 Then gop = arr(i, 2)
         For i = 2 To UBound(arr)
             c = arr(i - 1, 3)
             b = arr(i, 3)
             If b = c Then
                a = a + 1
                For j = 1 To 4
                    kq(a, j) = arr(i, j)
                Next j
             ElseIf b > c Then
                If b = 1 Then
                   a = a + 1
                   For j = 1 To 4
                      kq(a, j) = arr(i, j)
                   Next j
                   gop = arr(i, 2) & "("
               ElseIf b > 1 Then
                   a = a + 1
                    For j = 1 To 4
                      kq(a, j) = arr(i, j)
                   Next j
                   gop = gop & arr(i, 2) & ","
               End If
            ElseIf b < c Then
                    a = a + 1
                   kq(a, 2) = Left(gop, Len(gop) - 1) & ")"
                   gop = Empty
                   a = a + 1
                   For j = 1 To 4
                      kq(a, j) = arr(i, j)
                   Next j
                 
           End If
      Next i
      lr = .Range("o" & Rows.Count).End(xlUp).Row
      If lr > 4 Then .Range("o5:R" & lr).ClearContents
      If a Then .Range("o5:r5").Resize(a).Value = kq
  End With
Application.ScreenUpdating = True
End Sub

 

[thanhtam_thanhtam]

Bạn thử.Chắc vẫn còn sót vài trường hợp.

Sub chuyendulieu()
Application.ScreenUpdating = False
    Dim arr, a As Long, lr As Long, i As Long, kq, gop As String, b As Long, j As Long, c As Long
    With Sheets("Record")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr < 5 Then Exit Sub
         arr = .Range("A5:D" & lr).Value
         ReDim kq(1 To UBound(arr) + 1000, 1 To 4)
                For j = 1 To 4
                    kq(1, j) = arr(1, j)
                Next j
         b = arr(1, 3)
         a = 1
         If b = 1 Then gop = arr(i, 2)
         For i = 2 To UBound(arr)
             c = arr(i - 1, 3)
             b = arr(i, 3)
             If b = c Then
                a = a + 1
                For j = 1 To 4
                    kq(a, j) = arr(i, j)
                Next j
             ElseIf b > c Then
                If b = 1 Then
                   a = a + 1
                   For j = 1 To 4
                      kq(a, j) = arr(i, j)
                   Next j
                   gop = arr(i, 2) & "("
               ElseIf b > 1 Then
                   a = a + 1
                    For j = 1 To 4
                      kq(a, j) = arr(i, j)
                   Next j
                   gop = gop & arr(i, 2) & ","
               End If
            ElseIf b < c Then
                    a = a + 1
                   kq(a, 2) = Left(gop, Len(gop) - 1) & ")"
                   gop = Empty
                   a = a + 1
                   For j = 1 To 4
                      kq(a, j) = arr(i, j)
                   Next j
                
           End If
      Next i
      lr = .Range("o" & Rows.Count).End(xlUp).Row
      If lr > 4 Then .Range("o5:R" & lr).ClearContents
      If a Then .Range("o5:r5").Resize(a).Value = kq
  End With
Application.ScreenUpdating = True
End Sub

Cám ơn bạn rất nhiều, rất là tiện luôn ạ