Ghép dòng với nhiều điều kiện

[pt_hcl]

Sửa lại code theo yêu cầu của chủ Topic.

Sub GPE()
Application.ScreenUpdating = False
Dim i As Long, Dong1 As Long, Dong2 As Long, Dong3 As Long, Dong4 As Long, Dong5 As Long
Dim SoDong As Long, SoCot As Long
Dim EndR As Long, EndC As String
Dim StartR As Long, StartC As String
Dim Nm As Names
Dim Arr() As String, ViTri As Long
ReDim Arr(1 To Sheet1.Rows.Count, 1 To 1)
On Error Resume Next
StartR = 4
StartC = "B"
EndR = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
EndC = Replace(Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Address(0, 0), "1", "")
For i = 1 To 5
    ActiveWorkbook.Names("RngDong" & i).Delete
Next
Sheet7.Cells.ClearContents
SoDong = InputBox("Nhap so dong can ghep" & vbNewLine & "2 <= [So dong ghep] <= 5")
SoCot = InputBox("Nhap so cot rong toi da" & vbNewLine & "[So cot rong] > 0")
For i = 1 To SoDong
    ActiveWorkbook.Names.Add Name:="RngDong" & i, RefersTo:=0
Next
    ActiveWorkbook.Names.Add Name:="Ghep", RefersTo:="=RngDong1+RngDong2" & IIf(SoDong >= 3, "+RngDong3", "") & IIf(SoDong >= 4, "+RngDong4", "") & IIf(SoDong >= 5, "+RngDong5", "")
For Dong1 = StartR To EndR
    ActiveWorkbook.Names("RngDong1").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong1 & ":$" & EndC & "$" & Dong1
    For Dong2 = Dong1 + 1 To EndR
        If ViTri = Sheet1.Rows.Count Then GoTo HetDong
        ActiveWorkbook.Names("RngDong2").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong2 & ":$" & EndC & "$" & Dong2
        If SoDong > 2 Then
            For Dong3 = Dong2 + 1 To EndR
                If ViTri = Sheet1.Rows.Count Then GoTo HetDong
                ActiveWorkbook.Names("RngDong3").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong3 & ":$" & EndC & "$" & Dong3
                    If SoDong > 3 Then
                        For Dong4 = Dong3 + 1 To EndR
                            If ViTri = Sheet1.Rows.Count Then GoTo HetDong
                            ActiveWorkbook.Names("RngDong4").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong4 & ":$" & EndC & "$" & Dong4
                                If SoDong = 5 Then
                                    For Dong5 = Dong4 + 1 To EndR
                                        If ViTri = Sheet1.Rows.Count Then GoTo HetDong
                                        ActiveWorkbook.Names("RngDong5").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong5 & ":$" & EndC & "$" & Dong5
                                            If KiemTra(SoCot, SoDong) Then
                                                ViTri = ViTri + 1
                                                Arr(ViTri, 1) = ""
                                                For i = 1 To SoDong
                                                    ViTri = ViTri + 1
                                                    Arr(ViTri, 1) = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Range("RngDong" & i).Offset(0, -1).Resize(, Range("RngDong" & i).Columns.Count + 1))), "-")
                                                Next
                                            End If
                                    Next
                                ElseIf SoDong = 4 Then
                                    If KiemTra(SoCot, SoDong) Then
                                        ViTri = ViTri + 1
                                        Arr(ViTri, 1) = ""
                                        For i = 1 To SoDong
                                            ViTri = ViTri + 1
                                            Arr(ViTri, 1) = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Range("RngDong" & i).Offset(0, -1).Resize(, Range("RngDong" & i).Columns.Count + 1))), "-")
                                        Next
                                    End If
                                End If
                        Next
                    ElseIf SoDong = 3 Then
                        If KiemTra(SoCot, SoDong) Then
                            ViTri = ViTri + 1
                            Arr(ViTri, 1) = ""
                            For i = 1 To SoDong
                                ViTri = ViTri + 1
                                Arr(ViTri, 1) = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Range("RngDong" & i).Offset(0, -1).Resize(, Range("RngDong" & i).Columns.Count + 1))), "-")
                            Next
                        End If
                    End If
            Next
        ElseIf SoDong = 2 Then
            If KiemTra(SoCot, SoDong) Then
                ViTri = ViTri + 1
                Arr(ViTri, 1) = ""
                For i = 1 To SoDong
                    ViTri = ViTri + 1
                    Arr(ViTri, 1) = Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(Range("RngDong" & i).Offset(0, -1).Resize(, Range("RngDong" & i).Columns.Count + 1))), "-")
                Next
            End If
        End If
    Next
Next
HetDong:
Sheet7.Range("A1:A" & Application.WorksheetFunction.Min(ViTri, Sheet1.Rows.Count)).Value = Arr
Range(Sheet7.[A1], Sheet7.[A65536].End(xlUp)).TextToColumns [A1], 1, , , 1, , , , 1, "-"
Application.ScreenUpdating = True
End Sub

Private Function KiemTra(CotRong As Long, DongGhep As Long) As Boolean
    Dim StrGhep As String
    StrGhep = "-" & Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose([Ghep])), "-") & "-"
    StrGhep = Right(StrGhep, Len(LTrim(Replace(StrGhep, "-0", "  "))))
    KiemTra = InStr(StrGhep, Replace(Space(CotRong + 1), " ", "-0") & "-") = 0 And InStr(StrGhep, Replace(Space(CotRong), " ", "-0") & "-") > 0
End Function

Mong bạn huuthang_bd và các bạn có thể xem giúp trường hợp này không ạ? Thay cho điều kiện tìm nhóm dòng với số cột rỗng, đổi lại là tìm nhóm dòng với số cột có dữ liệu thì mình sẽ sửa lại code như thế nào ạ? Rất mong các bạn giúp đỡ!