Ghép dòng với nhiều điều kiện (1 người xem)

[pt_hcl]

[FONT=+mn-ea]Mình gặp phải trường hợp hóc búa thân gửi GPE giúp đỡ:[/FONT]
[FONT=+mn-ea]Tìm và ghép n dòng thoả mãn điều kiện: (Đây là bài tổng quát)[/FONT]
[FONT=+mn-ea]- Nếu n dòng ghép lại có số cột rỗng lớn nhất ở trong hàng là m thì ít nhất có m cột đầu tiên phải rỗng là thoả mãn điều kiện và chép sang sheet khác![/FONT]
[FONT=+mn-ea]- Mình có gửi kèm theo file minh hoạ cho trường hợp cụ thể! [/FONT]
[FONT=+mn-ea]- Cảm ơn GPE![/FONT]
[FONT=+mn-ea]- Chúc một ngày Valentine vui vẻ - hạnh phúc![/FONT]
(Mình không hiểu vì sao với tên thành viên cũ: hcl_pt thì mình không thể nào tải file lên diễn đàn được đành phải đăng kí với tên mới- Mong GPE thông cảm)

 

[ChanhTQ@]

Bài toán của bạn có thể hiểu như thế này không vậy:

(|) Tìm vùng có ô rỗng lớn nhất trong dòng;

(|) Chỉ chọn ra các dòng có số ô rỗng lớn nhất kể từ đầu dòng;

(|) Đem các dòng thoả 2 điều kiện ghép với các dòng có số ô rỗng ít hơn các dòng này;

Ví dụ dòng 9 & dòng 16 có số ô rỗng lớn nhất là 6 ô & đều bắt đầu từ cột 'C'

Ta có thể đem lần lượt từ chúng ghép với các dòng có số ô rỗng cực đại nhỏ hơn hay =6 là OK chứ ghì?

Chờ tin bạn;

(Nếu bạn muốn kiểm tra lại NICH cũ đã được cho chuyển file lên hay chưa thì fát biểu vớ ban Điều hành để được thoả mãn iêu cầu)

 

[pt_hcl]

(|) Tìm vùng có ô rỗng lớn nhất trong dòng;

(|) Chỉ chọn ra các dòng có số ô rỗng lớn nhất kể từ đầu dòng;

(|) Đem các dòng thoả 2 điều kiện ghép với các dòng có số ô rỗng ít hơn các dòng này;

Ví dụ dòng 9 & dòng 16 có số ô rỗng lớn nhất là 6 ô & đều bắt đầu từ cột 'C'

Ta có thể đem lần lượt từ chúng ghép với các dòng có số ô rỗng cực đại nhỏ hơn hay =6 là OK chứ ghì?

Chờ tin bạn;

(Nếu bạn muốn kiểm tra lại NICH cũ đã được cho chuyển file lên hay chưa thì fát biểu vớ ban Điều hành để được thoả mãn iêu cầu)

Vâng! Như thế này bạn à: Mình xin lấy một ví dụ cụ thể để minh hoạ:
* Trường hợp tìm và ghép 2 dòng:
- Trường hợp 1: nếu 2 dòng ghép lại thoả mãn 2 điều kiện sau thì chép sang sheet2:
+ ĐK1: có số cột rỗng lớn nhất ở trong hàng là 1 (bắt đầu tính từ cột đầu tiên có dữ liệu)
+ ĐK2: Có ít nhất 1 cột đầu tiên liên tiếp tính từ cột C phải rỗng
Ví dụ như file mình gửi kèm: dòng 4 và dòng 5 là thoả mãn: ít nhất có 1 cột đầu tiên là cột C rỗng và số cột rỗng lớn nhất có trong hàng bắt đầu tính từ cột đầu tiên có dữ liệu là 1 => dòng 4-5 thoả mãn điều kiện sẽ được chép sang sheet2
- Trường hợp 2: nếu 2 dòng ghép lại thoả mãn 2 điều kiên sau thì chép sang sheet3:
+ ĐK1: có số cột rỗng lớn nhất ở trong hàng là 2 (bắt đầu tính từ cột đầu tiên có dữ liệu)
+ ĐK2: Có ít nhất 2 cột đầu tiên liên tiếp tính từ cột C phải rỗng
Ví dụ như file mình gửi kèm: dòng 5 và dòng 6 là thoả mãn: ít nhất có 2 cột đầu tiên là cột C; D rỗng và số cột rỗng lớn nhất có trong hàng bắt đầu tính từ cột đầu tiên có dữ liệu là 2 =>dòng 5-6 thoả mãn điều kiện sẽ được chép sang sheet3
- Tương tự với các trường hợp còn lại!
* Nói cách khác: Tìm và ghép 2 dòng (3 dòng) sao cho thoả mãn điều kiện: Số cột đầu tiên liên tiếp tính từ cột C phải rỗng và lớn hơn hoặc bằng số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên.
- Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 1 thì chép sang sheet2
- Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 2 thì chép sang sheet3
- Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 3 thì chép sang sheet4
- Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 4 thì chép sang sheet5
* Mong bạn xem xét và giúp đỡ! Chân thành cảm ơn bạn! Cảm ơn GPE!

 

[SA_DQ]

Minh đã viết lại macro xác định số ô rỗng cực đại có trong hàng (Macro trước chưa hoàn toàn đúng trong những trường hợp bạn vừa đưa lên)
& Mình cũng đã viết hàm người dùng xác định số ô rỗng cực đại trong hàng luôn rồi.
Như vậy vấn đề chép sẽ không là gì, nếu hiểu được í của bạn.

Tuy nhiên ta chưa hiểu nhau, đáng tiếc!

Tại cột 'C' của bạn chỉ có C17:C19 có dữ liệu, vậy các dòng này không thể thoả điều kiện để sang Sheet2 (?) Các dòng khác thỉ thoả hết nếu đem so với dòng đầu tiên của bạn (!) & Đã thoả thì chép hết theo cặp chứ gì?

Xong trang này ta sẽ sang trang tiếp!

 

[pt_hcl]

Minh đã viết lại macro xác định số ô rỗng cực đại có trong hàng (Macro trước chưa hoàn toàn đúng trong những trường hợp bạn vừa đưa lên)
& Mình cũng đã viết hàm người dùng xác định số ô rỗng cực đại trong hàng luôn rồi.
Như vậy vấn đề chép sẽ không là gì, nếu hiểu được í của bạn.

Tuy nhiên ta chưa hiểu nhau, đáng tiếc!

Tại cột 'C' của bạn chỉ có C17:C19 có dữ liệu, vậy các dòng này không thể thoả điều kiện để sang Sheet2 (?) Các dòng khác thỉ thoả hết nếu đem so với dòng đầu tiên của bạn (!) & Đã thoả thì chép hết theo cặp chứ gì?

Xong trang này ta sẽ sang trang tiếp!

Thật vui vì bạn đã giúp mình! Đúng vậy bạn ạ!
- Nếu cột C có dữ liệu thì bỏ qua!
Mình xin nói lại phần điều kiện và có kèm theo file minh hoạ:
* Tìm và ghép 2 dòng (3 dòng) sao cho thoả mãn điều kiện: Số cột đầu tiên liên tiếp tính từ cột C phải rỗng và lớn hơn hoặc ít nhất bằng số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên.
1, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 1 thì chép sang sheet2
2, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 2 thì chép sang sheet3
3, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 3 thì chép sang sheet4
4, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 4 thì chép sang sheet5
+ Mình xin gửi kèm theo file có lấy 2 ví dụ minh hoạ cho trường hợp 1 và 4 ở sheet1 và có dán trường hợp thoả mãn sang các sheet2 và sheet5!
Chân thành cảm ơn bạn!

 

[concogia]

Thật vui vì bạn đã giúp mình! Đúng vậy bạn ạ!
- Nếu cột C có dữ liệu thì bỏ qua!
Mình xin nói lại phần điều kiện và có kèm theo file minh hoạ:
* Tìm và ghép 2 dòng (3 dòng) sao cho thoả mãn điều kiện: Số cột đầu tiên liên tiếp tính từ cột C phải rỗng và lớn hơn hoặc ít nhất bằng số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên.
1, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 1 thì chép sang sheet2
2, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 2 thì chép sang sheet3
3, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 3 thì chép sang sheet4
4, Nếu số cột rỗng lớn nhất có trong hàng tính từ cột có dữ liệu đầu tiên là 4 thì chép sang sheet5
+ Mình xin gửi kèm theo file có lấy 2 ví dụ minh hoạ cho trường hợp 1 và 4 ở sheet1 và có dán trường hợp thoả mãn sang các sheet2 và sheet5!
Chân thành cảm ơn bạn!

Híc, đọc bài này dễ bị "tẩu hỏa nhập ma" quá
Mù mờ mình hiểu thế này:
1)- GHÉP 2 DÒNG: là gom chung dữ liệu các cột tương ứng của 2 dòng đó. Thí dụ ghép dòng 4 & 5 ta gom C4&C5; D4&D5......SI4&SI5
2)- Rỗng đầu tiên: là số ô rỗng liên tục tính từ cột C
3)- Rỗng trong hàng: là số ô rỗng liên tục tính từ cột có dữ liệu chấm dứt "Rỗng đầu tiên"
Nếu đúng như thế bạn thử chạy code này xem sao:

Public Sub Ghep2dong()
Dim Vung, I As Long, J As Long, K As Long, iDau As Long, iMax As Long, SoSanh As Long, M As Long, kK As Long
 Vung = [c4:si22].Value
     For I = 1 To UBound(Vung) - 1
      If Vung(I, 1) = "" Then
         For J = I + 1 To UBound(Vung)
           If Vung(J, 1) = "" Then
                For K = 1 To 501
                    If Vung(I, K) & Vung(J, K) = "" Then
                        iDau = iDau + 1
                    Else
                        kK = K
                        Exit For
                    End If
                Next K
                    For M = kK To 501
                        If Vung(I, M) & Vung(J, M) = "" Then
                            SoSanh = SoSanh + 1
                            iMax = Application.WorksheetFunction.Max(iMax, SoSanh)
                        Else
                            SoSanh = 0
                        End If
                    Next M
                        If iMax < 5 Then
                                    If iMax < iDau Or iMax = iDau Then
                                        Range(Cells(I + 3, 1), Cells(I + 3, 503)).Copy Sheets("sheet" & iMax + 1).[a1000].End(xlUp)(3)
                                        Range(Cells(J + 3, 1), Cells(J + 3, 503)).Copy Sheets("sheet" & iMax + 1).[a1000].End(xlUp)(2)
                                    End If
                        End If
                        iDau = 0: SoSanh = 0: iMax = 0
               End If
        Next J
       End If
    Next I
End Sub

Trúng thì tốt, còn trật thì mình cũng....chịu thua nó thội, nhìn chóng mặt lắm
Híc
Thân

 

[pt_hcl]

Híc, đọc bài này dễ bị "tẩu hỏa nhập ma" quá
Mù mờ mình hiểu thế này:
1)- GHÉP 2 DÒNG: là gom chung dữ liệu các cột tương ứng của 2 dòng đó. Thí dụ ghép dòng 4 & 5 ta gom C4&C5; D4&D5......SI4&SI5
2)- Rỗng đầu tiên: là số ô rỗng liên tục tính từ cột C
3)- Rỗng trong hàng: là số ô rỗng liên tục tính từ cột có dữ liệu chấm dứt "Rỗng đầu tiên"
Nếu đúng như thế bạn thử chạy code này xem sao:

Public Sub Ghep2dong()
Dim Vung, I As Long, J As Long, K As Long, iDau As Long, iMax As Long, SoSanh As Long, M As Long, kK As Long
Vung = [c4:si22].Value
For I = 1 To UBound(Vung) - 1
If Vung(I, 1) = "" Then
For J = I + 1 To UBound(Vung)
If Vung(J, 1) = "" Then
For K = 1 To 501
If Vung(I, K) & Vung(J, K) = "" Then
iDau = iDau + 1
Else
kK = K
Exit For
End If
Next K
For M = kK To 501
If Vung(I, M) & Vung(J, M) = "" Then
SoSanh = SoSanh + 1
iMax = Application.WorksheetFunction.Max(iMax, SoSanh)
Else
SoSanh = 0
End If
Next M
If iMax < 5 Then
If iMax < iDau Or iMax = iDau Then
Range(Cells(I + 3, 1), Cells(I + 3, 503)).Copy Sheets("sheet" & iMax + 1).[a1000].End(xlUp)(3)
Range(Cells(J + 3, 1), Cells(J + 3, 503)).Copy Sheets("sheet" & iMax + 1).[a1000].End(xlUp)(2)
End If
End If
iDau = 0: SoSanh = 0: iMax = 0
End If
Next J
End If
Next I
End Sub

Trúng thì tốt, còn trật thì mình cũng....chịu thua nó thội, nhìn chóng mặt lắm
Híc
Thân

Chúc ngày mới tốt lành!
- Vâng! Cách hiểu của Bạn đúng rồi ạ!
1)- GHÉP 2 DÒNG: là gom chung dữ liệu các cột tương ứng của 2 dòng đó. Thí dụ ghép dòng 4 & 5 ta gom C4&C5; D4&D5......SI4&SI5
2)- Rỗng đầu tiên: là số ô rỗng liên tục tính từ cột C
3)- Rỗng trong hàng: là số ô rỗng liên tục tính từ cột có dữ liệu chấm dứt "Rỗng đầu tiên": Đúng như vậy ạ! Nhưng rỗng Trong hàng thì có rất nhiều và mình phải tìm số ô rỗng trong hàng lớn nhất xét so sánh đối chiếu với số ô rỗng liên tục tính từ cột C (Số ô rỗng liên tục tính từ cột C phải lớn hơn hoặc bằng Số ô rỗng trong hàng lớn nhất)
- Mình đã chạy thử code của Bạn đưa lên nhưng mình thấy báo lỗi ở dòng :Range(Cells(I + 3, 1), Cells(I + 3, 503)).Copy Sheets("sheet" & iMax + 1).[a1000].End(xlUp)(3)
- Cảm ơn bạn đã giúp đỡ! Thân ái!

 

[SA_DQ]

Từ ít đến nhiều, mần trường hợp 4 trước

Bạn kiểm tra giúp nha! (File E2003 & mình xoá cột 'B' của bạn đi rồi)

 

[concogia]

Chúc ngày mới tốt lành!
- Vâng! Cách hiểu của Bạn đúng rồi ạ!
1)- GHÉP 2 DÒNG: là gom chung dữ liệu các cột tương ứng của 2 dòng đó. Thí dụ ghép dòng 4 & 5 ta gom C4&C5; D4&D5......SI4&SI5
2)- Rỗng đầu tiên: là số ô rỗng liên tục tính từ cột C
3)- Rỗng trong hàng: là số ô rỗng liên tục tính từ cột có dữ liệu chấm dứt "Rỗng đầu tiên": Đúng như vậy ạ! Nhưng rỗng Trong hàng thì có rất nhiều và mình phải tìm số ô rỗng trong hàng lớn nhất xét so sánh đối chiếu với số ô rỗng liên tục tính từ cột C (Số ô rỗng liên tục tính từ cột C phải lớn hơn hoặc bằng Số ô rỗng trong hàng lớn nhất)
- Mình đã chạy thử code của Bạn đưa lên nhưng mình thấy báo lỗi ở dòng :Range(Cells(I + 3, 1), Cells(I + 3, 503)).Copy Sheets("sheet" & iMax + 1).[a1000].End(xlUp)(3)
- Cảm ơn bạn đã giúp đỡ! Thân ái!

Híc, đưa file hao tài nguyên quá
Bạn thử xem sao
Thân
Bạn nhớ đứng ở sheet1 chạy code nhé

 

[pt_hcl]

Bạn kiểm tra giúp nha! (File E2003 & mình xoá cột 'B' của bạn đi rồi)

Vâng! Cảm ơn Bạn nhiều!
- Đây là trường hợp 4: phải thoả mãn 2 điều kiện:
1, Số cột đầu tiên liên tiếp rỗng: lớn hơn hoặc bằng 4.
2, Số cột rỗng liên tục trong hàng lớn nhất: bằng 4.
- Mình vừa kiểm tra và thấy phần kết quả ở sheet5 như sau ạ:
1, Số cột đầu tiên liên tiếp rỗng tính từ cột B (theo file của bạn) là từ 4 trở lên: thoả mãn.
2, Nhưng số cột rỗng liên tục trong hàng lớn nhất của một vài kết quả là chưa thoả mãn điều kiện ạ, ví dụ:
+ Kết quả ở dòng 5 và 6 hoặc dòng 14 và 15: số cột ô rỗng liên tục trong hàng lớn nhất là 3: Không thoả mãn (kết quả này đúng cho trường hợp 3: dán sang sheet4)
+ kết quả ở dòng 23 và 24: số cột ô rỗng liên tục trong hàng lớn nhất là 6: Không thoả mãn.
* Cảm ơn bạn và mong bạn xem lại giúp mình với! Chúc ngày thắng lợi! Thân ái

 

[pt_hcl]

Híc, đưa file hao tài nguyên quá
Bạn thử xem sao
Thân
Bạn nhớ đứng ở sheet1 chạy code nhé

Mình biết nói gì hơn nhỉ? Đúng quá Bạn à! Đúng là làm như vậy ạ! Như vậy là mình có code chạy 1 lúc cho cả 4 trường hợp! Thêm code của các bạn khác chạy cho từng trường hợp vậy là tuyệt vời quá!
- Cảm ơn Bạn rất nhiều! Nếu mình muốn làm với vùng dữ liệu rất lớn như: vùng= [c4:si719400] thì có được không ạ? Và nếu muốn thì mình sẽ sửa thông số code ở phần nào ạ? Mong bạn chỉ giúp!
- Rất mong tin của bạn! Cảm ơn mọi người! Cảm ơn GPE! Thân ái!

 

[SA_DQ]

Trường hợp 4: Nếu 2 dòng ghép lại có Số cột rỗng lớn nhất ở trong hàng là 4 thì ít nhất có 4 cột đầu tiên tính từ cột C phải rỗng là thoả mãn điều kiện => chép sang sheet 5 (4, 5, ...cột đầu tiên trở lên rỗng cũng thoả mãn điều kiện)

1, Số cột đầu tiên liên tiếp rỗng tính từ cột B (theo file của bạn) là từ 4 trở lên: thoả mãn.
2, Nhưng số cột rỗng liên tục trong hàng lớn nhất của một vài kết quả là chưa thoả mãn điều kiện ạ, ví dụ:
+ Kết quả ở dòng 5 và 6 hoặc dòng 14 và 15: số cột ô rỗng liên tục trong hàng lớn nhất là 3: Không thoả mãn (kết quả này đúng cho trường hợp 3: dán sang sheet4)

Lý ra bạn fải viết vầy chăng (?):
Trường hợp 4: Nếu 2 dòng ghép lại có số cột rỗng đầu hàng tối thiểu fải bằng 4 & số cột rỗng còn lại trong hàng (không kể các cột rỗng đầu hàng đã tính) fải bằng 4

 

[concogia]

Mình biết nói gì hơn nhỉ? Đúng quá Bạn à! Đúng là làm như vậy ạ! Như vậy là mình có code chạy 1 lúc cho cả 4 trường hợp! Thêm code của các bạn khác chạy cho từng trường hợp vậy là tuyệt vời quá!
- Cảm ơn Bạn rất nhiều! Nếu mình muốn làm với vùng dữ liệu rất lớn như: vùng= [c4:si719400] thì có được không ạ? Và nếu muốn thì mình sẽ sửa thông số code ở phần nào ạ? Mong bạn chỉ giúp!
- Rất mong tin của bạn! Cảm ơn mọi người! Cảm ơn GPE! Thân ái!

Vung= [c4:si719400] Bạn hỏi xong, bạn ...trả lời luôn rồi đó
Nhưng, bài này mình sử dụng vòng lặp, gán dữ liệu trực tiếp lên sheet, với dữ liệu 719400 dòng thì nó lặp 258,767,820,300 lần, trừ những dòng không thỏa thì mình cũng....không dám thử, híc, tội nghiệp cái máy lắm ( có khi "chơi" hết 5 ve mà nó chưa chạy xong nữa à)
Không biết bài này có dùng mảng làm trung gian gán kết quả được không nữa. Để mình thử xem, nếu có hồi âm là làm được, còn bạn thấy mình lặn mất tăm "hổng" sủi miếng bọt nào là mình "tèo" luôn rồi nhé
Thân

 

[pt_hcl]

Lý ra bạn fải viết vầy chăng (?):
Trường hợp 4: Nếu 2 dòng ghép lại có số cột rỗng đầu hàng tối thiểu fải bằng 4 & số cột rỗng còn lại trong hàng (không kể các cột rỗng đầu hàng đã tính) fải bằng 4

Vâng! Đúng rồi ạ! Ngữ Pháp Việt Nam mình chưa nhuần nhuyễn lắm nên cách diễn đạt còn khó hiểu! Mong bạn bỏ qua! Mình sẽ rút kinh nghiệm lần sau!
Cảm ơn bạn! Thân ái!

 

[pt_hcl]

Vung= [c4:si719400] Bạn hỏi xong, bạn ...trả lời luôn rồi đó
Nhưng, bài này mình sử dụng vòng lặp, gán dữ liệu trực tiếp lên sheet, với dữ liệu 719400 dòng thì nó lặp 258,767,820,300 lần, trừ những dòng không thỏa thì mình cũng....không dám thử, híc, tội nghiệp cái máy lắm ( có khi "chơi" hết 5 ve mà nó chưa chạy xong nữa à)
Không biết bài này có dùng mảng làm trung gian gán kết quả được không nữa. Để mình thử xem, nếu có hồi âm là làm được, còn bạn thấy mình lặn mất tăm "hổng" sủi miếng bọt nào là mình "tèo" luôn rồi nhé
Thân

Hì! Cảm ơn bạn rất nhiều! Mình tin bạn sẽ không có chuyện "lặn mất tăm "hổng" sủi miếng bọt nào" đâu! Thân, chờ tin tốt lành!

 

[SA_DQ]

Hãy kiểm theo file

​

 

[pt_hcl]

​

Vâng! Trường hợp 4 đúng rồi ạ! Tuyệt quá! Cảm ơn bạn nhiều! Mong tin bạn các trường hợp khác ạ! Chúc bạn một ngày thành công!

 

[SA_DQ]

Từ 2 trở lên đây; khoan hãy thử với 1 nha

Cách xài:

Cho macro TongHop chạy;
Khi xuất hiện hộp thoại iêu cầu nhập 1 số thì ta nhập ký số > 1 vố đó (Với điều kiện Sheets(i+1) đã tồn tại - i là số sẽ nhập vô.

 

[pt_hcl]

Cách xài:

Cho macro TongHop chạy;
Khi xuất hiện hộp thoại iêu cầu nhập 1 số thì ta nhập ký số > 1 vố đó (Với điều kiện Sheets(i+1) đã tồn tại - i là số sẽ nhập vô.
- Tuyệt vời! Hay qúa! Để mình sẽ kiểm tra với dữ liệu lớn hơn xem sao? Không biết cảm ơn bạn thế nào? Cảm ơn bạn nhiều! Hi vọng với dữ liệu lớn vẫn thoả mãn.
- Mình thành thật xin lỗi các bạn cho mình spam một chút:
+ Đoạn code sau có phải chỉ sử dụng được cho excel2003 phải không ạ? Mình cho chạy sang excel 2007 thì khi số cột dữ liệu lên tới 257 dòng là báo lỗi? Đây là phần code lọc ô trống max bạn SA_DQ đã viết giúp đỡ, nhờ bạn xem và giúp mình sửa thông số ở phần nào để mình có thể tăng thêm số cột? Chân thành cảm ơn bạn!
Sub MaxBlanksInRows()
Dim eCol As Byte, eRw As Long, jJ As Long, Max_ As Byte, SoOR As Byte
Dim RgR As Range, Rng0 As Range, lRng As Range
Dim Timer_ As Double

Sheets("S1").Select: Timer_ = Timer
Set Rng0 = [B2].CurrentRegion
eCol = Rng0.Columns.Count: eRw = Rng0.Rows.Count
For jJ = 4 To eRw
If Cells(jJ, "B").Value = "" Then
Set Rng0 = Cells(jJ, "a") 'Neu B Rong Thi Lay A'
Else 'Nguoc Lai Thi Lay O Truoc O Rong'
Set Rng0 = Cells(jJ, "A").End(xlToRight)
End If
'Rng0 La O Co Du Lieu Truoc O Rong'
Do
Set RgR = Rng0.End(xlToRight) 'RgR: O Du Lieu Sau Day O Rong'
If RgR.Column > eCol Then
If Not lRng Is Nothing Then lRng.Interior.ColorIndex = 39:
Cells(jJ, eCol + 2).Value = Max_ - 1: Max_ = 0
Set lRng = Nothing: Exit Do
End If
'SoOR:= So O Rong Tim Duoc:'
SoOR = Range(Rng0, RgR).Count - 1
If SoOR > Max_ Then
Max_ = SoOR: Set lRng = Rng0.Offset(, 1).Resize(, SoOR - 1)

End If
Set Rng0 = RgR
Loop
Next jJ
[iD1].Value = Timer - Timer_
End Sub

 

[ChanhTQ@]

Thay vì

[SIZE=3][FONT=Times New Roman]Dim eCol As Byte, eRw As Long, jJ As Long, Max_ As Byte, SoOR As Byte

Ta thử sửa lại là :

Dim eCol As Long, eRw As Long, jJ As Long, Max_ As Byte, SoOR As Byte

[/FONT][/SIZE]

 

[pt_hcl]

Thay vì

[SIZE=3][FONT=Times New Roman]Dim eCol As Byte, eRw As Long, jJ As Long, Max_ As Byte, SoOR As Byte

Ta thử sửa lại là :

Dim eCol As Long, eRw As Long, jJ As Long, Max_ As Byte, SoOR As Byte

[/FONT][/SIZE]

Hix, Không ngủ được dậy nghiên cứu! Cảm ơn bạn ChanhTQ nhiều!

 

[SA_DQ]

Bài toán tổng quát của bạn sẽ kết thúc trong nay mai 1 cách hoàn mĩ!

& đây là macro xét 3 dòng cho trường hợp 5 ô trống!

 Sub GPE

 ' Xin Các Bạn Xem Bài Bên Dưới Liền Kề Trích Dẫn Đầy Đủ'

End Sub

(Trước khi ta đến trường hợp tổng quát với 3 dòng

Xin hỏi anh Cò Già chút: Đáng fạt tác gia topic do mô tả công việc lượm thượm không nhỉ?

 

[pt_hcl]

& đây là macro xét 3 dòng cho trường hợp 5 ô trống!

Option Explicit
 
Sub Ghep3Dong_5()
Dim Rws As Long, Col As Integer, Jj As Long, wW As Long, zZ As Long
Dim jRg As Range, wRg As Range, zRg As Range, WF As Object, Sh As Worksheet
Dim Max_ As Byte, Timer_ As Double: Const Ct As Integer = 256
 
Timer_ = Timer: Sheet1.Select
Rws = [A65500].End(xlUp).Row: Set Sh = Sheets("S5") '<=|'
Sh.[A1].Resize(9 * Rws, Ct).Clear:
Set WF = Application.WorksheetFunction
For Jj = 4 To Rws - 2
Set jRg = Range(Cells(Jj, "B"), Cells(Jj, "IU"))
If WF.Sum(jRg(1).Resize(, 5)) = 0 Then '5:=Num'
For wW = Jj + 1 To Rws - 1
Set wRg = Range(Cells(wW, "B"), Cells(wW, "IU"))
If WF.Sum(wRg(1).Resize(, 5)) = 0 Then '5:=Num'
For zZ = wW + 1 To Rws
Set zRg = Range(Cells(zZ, "B"), Cells(zZ, "IU"))
If WF.Sum(zRg(1).Resize(, 5)) = 0 Then '5:=Num'
With Sh.[A65500].End(xlUp).Offset(2)
.Resize(, Ct).Value = jRg(0).Resize(, Ct).Value
.Offset(1).Resize(, Ct).Value = wRg(0).Resize(, Ct).Value
.Offset(2).Resize(, Ct).Value = zRg(0).Resize(, Ct).Value
End With
End If
Next zZ
End If
Next wW
End If
Next Jj
 
Sh.Select: Set Sh = Nothing
Rws = [A65500].End(xlUp).Row + 1: Set zRg = [A1]
For Jj = 3 To Rws Step 4
Cells(Jj, 1).Interior.ColorIndex = 45
For wW = (5 + 2) To Ct '5:=Num'
Set jRg = Cells(1, wW): Set wRg = jRg.Offset(, -1)
With Cells(Jj, wW)
jRg.Value = .Value + .Offset(1).Value + .Offset(2).Value
End With
If jRg.Value = 0 And wRg.Value = 0 Then
Col = Col + 1
If Max_ < Col Then Max_ = Col
If Max_ > 5 - 1 Then Exit For '5:=Num'
Else
Col = 0
End If
Next wW
If Max_ <> 5 - 1 Then '5:=Num'
Set zRg = Union(zRg, Cells(Jj, 1).Resize(3))
End If
Max_ = 0: Col = 0
Next Jj
zRg.EntireRow.Delete: [A1].Value = "GPE"
[B1].Value = Timer - Timer_
End Sub

(Trước khi ta đến trường hợp tổng quát với 3 dòng

Xin hỏi anh Cò Già chút: Đáng fạt tác gia topic do mô tả công việc lượm thượm không nhỉ?

- Hì! Vâng! Mình xin nhận lỗi để lần sau rút kinh nghiệm! Cảm ơn bạn HYen nhiều lắm! Tin này của bạn có thể nói là tin vui nhất trong ngày!
- Cảm ơn các bạn, cảm ơn GPE! Mong chờ tin tốt lành tiếp theo! Thân ái!

 

[ChanhTQ@]

Đây nè bạn, đủ rồi đó nha

[B]Sub Ghep3Dong()[/B]
 Dim Nomer As Byte
 
 Nomer = InputBox("Hay Nhap So Tri: ", "GPE Xin Luu Y: < 11", "5")
 GPE Nomer
[B]End Sub[/B]

Sub GPE(Num)
 Dim Rws As Long, Col As Integer, Jj As Long, wW As Long, zZ As Long
 Dim jRg As Range, wRg As Range, zRg As Range, WF As Object, Sh As Worksheet
 Dim Max_ As Byte, Timer_ As Double:            Const Ct As Integer = 256
 
 Timer_ = Timer:                                Sheet1.Select
 Rws = [A65500].End(xlUp).Row:                  Set Sh = Sheets("S5") '<=|'
 Sh.Range(Sh.[A1], Sh.[A65500].End(xlUp)).Resize(, Ct).Clear:
 Set WF = Application.WorksheetFunction
 For Jj = 4 To Rws - 2
    Set jRg = Range(Cells(Jj, "B"), Cells(Jj, "IU"))
    Set jRg = Cells(Jj, "B").Resize(, Ct - 2)
    If WF.Sum(jRg(1).Resize(, Num)) = 0 Then     '*'
        For wW = Jj + 1 To Rws - 1
            Set wRg = Cells(wW, "B").Resize(, Ct - 2)
            If WF.Sum(wRg(1).Resize(, Num)) = 0 Then         '*'
                For zZ = wW + 1 To Rws
                    Set zRg = Cells(zZ, "B").Resize(, Ct - 2)
                    If WF.Sum(zRg(1).Resize(, Num)) = 0 Then         '*'
                        With Sh.[A65500].End(xlUp).Offset(2)
                            .Resize(, Ct).Value = jRg(0).Resize(, Ct).Value
                            .Offset(1).Resize(, Ct).Value = wRg(0).Resize(, Ct).Value
                            .Offset(2).Resize(, Ct).Value = zRg(0).Resize(, Ct).Value
                        End With
                    End If
                Next zZ
            End If
        Next wW
    End If
 Next Jj
 Sh.Select:                                 Set Sh = Nothing
 [c2].Value = Timer - Timer_
 Rws = [A65500].End(xlUp).Row + 1:          Set zRg = [A1]
 For Jj = 3 To Rws Step 4
    Cells(Jj, 1).Interior.ColorIndex = 45
    For wW = (Num + 2) To Ct                  '*'
        Set jRg = Cells(1, wW):             Set wRg = jRg.Offset(, -1)
        With Cells(Jj, wW)
            jRg.Value = .Value + .Offset(1).Value + .Offset(2).Value
        End With
        If jRg.Value = 0 And wRg.Value = 0 Then
            Col = Col + 1
            If Max_ < Col Then Max_ = Col
            If Max_ > Num - 1 Then Exit For   '*'
        Else
            Col = 0
        End If
    Next wW
    If Max_ <> Num - 1 Then                   '*'
        Set zRg = Union(zRg, Cells(Jj, 1).Resize(4))
    End If
    Max_ = 0:                               Col = 0
 Next Jj
 zRg.EntireRow.Delete:                      [A1].Value = "GPE"
 [B1].Value = Timer - Timer_
End Sub

 

[huuthang_bd]

All in one

Tôi viết chung tất cả trong một code. Bạn có thể nhập số dòng cần ghép và điều kiện ghép (Số cột rỗng liên tiếp).
Khi chạy code sẽ hiện lên 2 cái InputBox.
InputBox đầu: Nhập số dòng cần ghép. Từ 2 đến 5 dòng thôi nhé. Số dòng càng nhiều thì xử lý càng lâu.
InputBox sau: Nhập số cột rỗng làm điều kiện. Lớn hơn 0.
Tốc độ tương đối ổn. Bạn tải về thêm dữ liệu vào rồi test thử xem sao.

Sub GPE()
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
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
    If Application.WorksheetFunction.Sum([RngDong1].Resize(, SoCot)) = 0 Then
        For Dong2 = Dong1 + 1 To EndR
            ActiveWorkbook.Names("RngDong2").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong2 & ":$" & EndC & "$" & Dong2
            If Application.WorksheetFunction.Sum([RngDong2].Resize(, SoCot)) = 0 Then
                If SoDong > 2 Then
                    For Dong3 = Dong2 + 1 To EndR
                        ActiveWorkbook.Names("RngDong3").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong3 & ":$" & EndC & "$" & Dong3
                        If Application.WorksheetFunction.Sum([RngDong3].Resize(, SoCot)) = 0 Then
                            If SoDong > 3 Then
                                For Dong4 = Dong3 + 1 To EndR
                                    ActiveWorkbook.Names("RngDong4").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong4 & ":$" & EndC & "$" & Dong4
                                    If Application.WorksheetFunction.Sum([RngDong4].Resize(, SoCot)) = 0 Then
                                        If SoDong = 5 Then
                                            For Dong5 = Dong4 + 1 To EndR
                                                ActiveWorkbook.Names("RngDong5").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong5 & ":$" & EndC & "$" & Dong5
                                                If Application.WorksheetFunction.Sum([RngDong5].Resize(, SoCot)) = 0 Then
                                                    Call KiemTra(SoCot, SoDong)
                                                End If
                                            Next
                                        ElseIf SoDong = 4 Then
                                            Call KiemTra(SoCot, SoDong)
                                        End If
                                    End If
                                Next
                            ElseIf SoDong = 3 Then
                                Call KiemTra(SoCot, SoDong)
                            End If
                        End If
                    Next
                ElseIf SoDong = 2 Then
                    Call KiemTra(SoCot, SoDong)
                End If
            End If
        Next
    End If
Next
End Sub

Sub KiemTra(CotRong As Long, DongGhep As Long)
    Dim StrGhep As String, k As Long, Sh As Worksheet
    Set ShKetQua = Sheet7
    StrGhep = "-" & Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose([Ghep])), "-") & "-"
    StrGhep = Right(StrGhep, Len(LTrim(Replace(StrGhep, "-0", "  "))))
        If InStr(StrGhep, Replace(Space(CotRong + 1), " ", "-0") & "-") = 0 And InStr(StrGhep, Replace(Space(CotRong), " ", "-0") & "-") > 0 Then
            ShKetQua.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1).Value = "------------------------------------------------"
            For k = 1 To DongGhep
                ShKetQua.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1).Resize(, Range("RngDong" & k).Columns.Count + 1).Value = Range("RngDong" & k).Offset(0, -1).Resize(, Range("RngDong" & k).Columns.Count + 1).Value
            Next
        End If
End Sub

 

[pt_hcl]

Tôi viết chung tất cả trong một code. Bạn có thể nhập số dòng cần ghép và điều kiện ghép (Số cột rỗng liên tiếp).
Khi chạy code sẽ hiện lên 2 cái InputBox.
InputBox đầu: Nhập số dòng cần ghép. Từ 2 đến 5 dòng thôi nhé. Số dòng càng nhiều thì xử lý càng lâu.
InputBox sau: Nhập số cột rỗng làm điều kiện. Lớn hơn 0.
Tốc độ tương đối ổn. Bạn tải về thêm dữ liệu vào rồi test thử xem sao.

Sub GPE()
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
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
    If Application.WorksheetFunction.Sum([RngDong1].Resize(, SoCot)) = 0 Then
        For Dong2 = Dong1 + 1 To EndR
            ActiveWorkbook.Names("RngDong2").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong2 & ":$" & EndC & "$" & Dong2
            If Application.WorksheetFunction.Sum([RngDong2].Resize(, SoCot)) = 0 Then
                If SoDong > 2 Then
                    For Dong3 = Dong2 + 1 To EndR
                        ActiveWorkbook.Names("RngDong3").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong3 & ":$" & EndC & "$" & Dong3
                        If Application.WorksheetFunction.Sum([RngDong3].Resize(, SoCot)) = 0 Then
                            If SoDong > 3 Then
                                For Dong4 = Dong3 + 1 To EndR
                                    ActiveWorkbook.Names("RngDong4").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong4 & ":$" & EndC & "$" & Dong4
                                    If Application.WorksheetFunction.Sum([RngDong4].Resize(, SoCot)) = 0 Then
                                        If SoDong = 5 Then
                                            For Dong5 = Dong4 + 1 To EndR
                                                ActiveWorkbook.Names("RngDong5").RefersTo = "='" & Sheet1.Name & "'!$" & StartC & "$" & Dong5 & ":$" & EndC & "$" & Dong5
                                                If Application.WorksheetFunction.Sum([RngDong5].Resize(, SoCot)) = 0 Then
                                                    Call KiemTra(SoCot, SoDong)
                                                End If
                                            Next
                                        ElseIf SoDong = 4 Then
                                            Call KiemTra(SoCot, SoDong)
                                        End If
                                    End If
                                Next
                            ElseIf SoDong = 3 Then
                                Call KiemTra(SoCot, SoDong)
                            End If
                        End If
                    Next
                ElseIf SoDong = 2 Then
                    Call KiemTra(SoCot, SoDong)
                End If
            End If
        Next
    End If
Next
End Sub

Sub KiemTra(CotRong As Long, DongGhep As Long)
    Dim StrGhep As String, k As Long, Sh As Worksheet
    Set ShKetQua = Sheet7
    StrGhep = "-" & Join(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose([Ghep])), "-") & "-"
    StrGhep = Right(StrGhep, Len(LTrim(Replace(StrGhep, "-0", "  "))))
        If InStr(StrGhep, Replace(Space(CotRong + 1), " ", "-0") & "-") = 0 And InStr(StrGhep, Replace(Space(CotRong), " ", "-0") & "-") > 0 Then
            ShKetQua.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1).Value = "------------------------------------------------"
            For k = 1 To DongGhep
                ShKetQua.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1).Resize(, Range("RngDong" & k).Columns.Count + 1).Value = Range("RngDong" & k).Offset(0, -1).Resize(, Range("RngDong" & k).Columns.Count + 1).Value
            Next
        End If
End Sub

Híc, Mình đang ngồi chiêm ngưỡng tác phẩm của bạn! (Bao giờ mình có thể làm được như vậy nhỉ?)
- Cảm ơn bạn nhiều quá! Mình sẽ test thử với dữ liệu nhiều hơn xem sao!
- Chúc bạn luôn gặp nhiều may mắn! Cảm ơn GPE!

 

[ChanhTQ@]

Hãy giành ra 8 fút để chạy thử 2.000 dòng dữ liệu giả lập này

​

 

[ThuNghi]

​

Cáo ơn Bác Sa nhiều, với dạng bài này e có làm thử nhưng với kết quả gần 800.000 dòng thì chẳng Ex nào mà lưu nổi cả.
Chắc tác giả nếu hết yêu cầu 1 lượt rối kiếm phần mềm nào mà lưu nổi dạng ADO lưu qua Acc họa may.
File lớn quá nên cũng chả có kiên nhẫn test, mà test ít dòng thì chưa chắc là hoàn thiện vì data quá lớn.

 

[pt_hcl]

​

​

Vâng! Cảm ơn bạn! Đúng là tốc độ như vậy rất tuyệt bạn ChanhTQ ạ!
- Nếu mình muốn test thử với n dòng dữ liệu thì mình sẽ chỉnh đoạn code ở thông số nào ạ? (ví dụ mình muốn test với 11345 dòng dữ liệu chẳng hạn?)
- Cảm ơn bạn rất nhiều! Mong tin bạn rất nhiều!

Option Explicit
Sub Ghep3Dong()
Dim Nomer As Byte

Nomer = InputBox("Hay Nhap So Tri: ", "GPE Xin Luu Y: < 11", "5")
GPE Nomer
End Sub
Sub GPE(Num)
Dim Rws As Long, Col As Integer, jJ As Long, wW As Long, zZ As Long, Ff As Integer
Dim jRg As Range, wRg As Range, zRg As Range, WF As Object, Sh As Worksheet
Dim Max_ As Byte, Timer_ As Double, Tong As Long
Const Ct As Integer = 398

Timer_ = Timer: Sheets("S2").Select
Rws = [A65535].End(xlUp).Row: Set Sh = Sheets("S5") '<=|'
Sh.Range(Sh.[A1], Sh.[A65500].End(xlUp)).Resize(, Ct).Clear:
Set WF = Application.WorksheetFunction
For jJ = 4 To Rws - 2
Set jRg = Range(Cells(jJ, "B"), Cells(jJ, "OH"))
Set jRg = Cells(jJ, "B").Resize(, Ct - 2)
If WF.Sum(jRg(1).Resize(, Num)) = 0 Then
For wW = jJ + 1 To Rws - 1
Set wRg = Cells(wW, "B").Resize(, Ct - 2)
If WF.Sum(wRg(1).Resize(, Num)) = 0 Then
For zZ = wW + 1 To Rws
Set zRg = Cells(zZ, "B").Resize(, Ct - 2)
If WF.Sum(zRg(1).Resize(, Num)) = 0 Then
With Sh.[A65500].End(xlUp).Offset(2)
If .Row > 65500 Then GoTo 999
.Resize(, Ct).Value = jRg(0).Resize(, Ct).Value
.Offset(1).Resize(, Ct).Value = wRg(0).Resize(, Ct).Value
.Offset(2).Resize(, Ct).Value = zRg(0).Resize(, Ct).Value
End With
End If
Next zZ
End If
Next wW
End If
Next jJ
999
Sh.Select: Set Sh = Nothing
[c2].Value = Timer - Timer_: Set jRg = Nothing
Rws = [A65500].End(xlUp).Row + 1: Set wRg = Nothing
Set zRg = [A1]
For jJ = 3 To Rws Step 4
Cells(jJ, 1).Interior.ColorIndex = 34 + jJ Mod 9
For wW = (Num + 2) To Ct
Tong = WF.Sum(Cells(jJ, wW).Resize(3))
If Tong = 0 Then
If WF.Sum(Cells(jJ, wW - 1).Resize(3)) = 0 Then
Col = Col + 1
If Max_ < Col Then Max_ = Col
If Max_ > Num - 1 Then Exit For
End If
Else
Col = 0
End If
Next wW
If Max_ <> Num - 1 Then
Set zRg = Union(zRg, Cells(jJ, 1).Resize(4))
End If
Max_ = 0: Col = 0
Next jJ
[d2] = zRg.Count - 1
zRg.EntireRow.Delete: [A1].Value = "GPE"
[B1].Value = Timer - Timer_
End Sub

 

[SA_DQ]

If .Row > 65500 Then GoTo 999

Bạn thấy dòng lệnh này không?

Thực ra, nếu bạn xem kết quả tại 'S5' sẽ thấy nó thể hiện 1 fần nhỏ nhoi kết quả của quá trình mà thôi (Vì hàng đầu của 3 dòng cuối kết quả vẫn còn mang mã A04.) (& nếu bạn đủ kiên nhẫn, bạn có thể tăng số này lên gấp đôi, gấp 3 hay hơn nữa xem sao; Vì mình chỉ có E2003 mà!)

Bổ sung:

ví dụ mình muốn test với 11345 dòng dữ liệu chẳng hạn?

Ngoài ra ta còn fải đổi các con số 65500 hay 65535 thành những con số lớn hơn 1 cách tương ứng thích hợp nữa đó bạn

Thân ái!

 

[huuthang_bd]

Không biết lỗi chỗ nào mà code của bác ChanhTQ nhiều khi cho kết quả không đúng. Như trong file dữ liệu tôi gửi kèm, 3 dòng đầu không thỏa điều kiện nhưng code lại ghép thành 1 kết quả, 3 dòng sau thỏa điều kiện như code không ghép lại.

Tôi sửa lại code của tôi một chút, không ghi dữ liệu trực tiếp vào file mà gán vào mảng trước rồi mới ghi vào file. Đương nhiên cách này tốc độ sẽ nhanh hơn cách trước.

 

[pt_hcl]

Không biết lỗi chỗ nào mà code của bác ChanhTQ nhiều khi cho kết quả không đúng. Như trong file dữ liệu tôi gửi kèm, 3 dòng đầu không thỏa điều kiện nhưng code lại ghép thành 1 kết quả, 3 dòng sau thỏa điều kiện như code không ghép lại.

Tôi sửa lại code của tôi một chút, không ghi dữ liệu trực tiếp vào file mà gán vào mảng trước rồi mới ghi vào file. Đương nhiên cách này tốc độ sẽ nhanh hơn cách trước.

Vâng! Tuyệt quá bạn à! Hoàn hảo! Cảm ơn bạn rất nhiều!

Tôi sửa lại code của tôi một chút, không ghi dữ liệu trực tiếp vào file mà gán vào mảng trước rồi mới ghi vào file. Đương nhiên cách này tốc độ sẽ nhanh hơn cách trước.

Bạn Huuthang_bd ơi! Bạn có thể xem giúp mình trường hợp này được không? Mình thấy cách của bạn rất hay và hợp lí! Mong bạn giúp đỡ! Mong GPE cùng xem hộ giúp trường hợp này ạ! Chân thành cảm ơn! Thân ái!

 

[huuthang_bd]

Vâng! Tuyệt quá bạn à! Hoàn hảo! Cảm ơn bạn rất nhiều!



Bạn Huuthang_bd ơi! Bạn có thể xem giúp mình trường hợp này được không? Mình thấy cách của bạn rất hay và hợp lí! Mong bạn giúp đỡ! Mong GPE cùng xem hộ giúp trường hợp này ạ! Chân thành cảm ơn! Thân ái!

Bạn test thử xem có bị lỗi gì không nhé.

 

[pt_hcl]

Bạn test thử xem có bị lỗi gì không nhé.

Vâng! Cảm ơn bạn nhiều! Mình sẽ test kiểm tra thử xem! Một lần xin cảm ơn bạn! Chúc may mắn! Thân!

 

[tinhyeulahanhphuc]

hỏi các bác 1 một chút

hỏi các bác 1 chút

Các bác cho em hỏi chút nhá
Em lưu giữ liệu vào ổ D nhưng cùng lúc đó giữ liệu cũng lưu vào my document. Bây giờ em ko muốn lưu như thế thì làm thế nào ah?Tức là mình lưu vào ổ nào thì dữ liệu chỉ lưu vào ổ đó thôi
Mng các bác giúp đỡ em.
Cang nhanh càng tôt các bác nhá
Em cảm ơn các bác!

 

[huuthang_bd]

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

 

[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

Thân gửi bạn Huuthang_bd và các bạn trong GPE!
* Rất mong bạn Huuthang và các bạn trong diễn đàn GPE chỉ giúp mình chỗ sửa lại đoạn code này một chút cho phù hợp với điều kiện mới của bài toán:
- Nếu Ở bài toán cũ là ghép với 2 dòng, 3 dòng, 4 dòng, và 5 dòng với số cột rỗng tùy ý mình nhập, theo cách sử lí như vậy là rất hay, rất tuyệt vời rồi ạ! Bây giờ mình muốn mình muốn ghép với 50 dòng, 60 dòng, 70 dòng, 80 dòng, 90 dòng lại với nhau thì mình sửa như thế nào ạ? (mình đã mày mò tự sửa mất gần 1 tháng nay mà chưa ra, đành phải làm phiền các bạn)
- Nếu các bạn chỉ cho mình chỗ sửa cụ thể cho một trường hợp (ví dụ ghép 50 dòng chẳng hạn) thì tốt quá, mình sẽ bắt chước sửa cho trường hợp còn lại! Nếu có thể các bạn có thể làm giúp mình tất các trường hợp rùi mình tự mày mò đối chiếu với cái cũ để tìm ra chỗ sửa được không ạ!
- Một lần nữa rất mong các bạn giúp đỡ! Xin chân thành cảm ơn các bạn! Từng giây chờ sự giúp đỡ! Thân ái!
- Nếu có thể mong các bạn có thể áp vào file này được không ạ?

 

[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

- GPE có thể xem giúp hộ mình trường hợp này với ạ! Với đoạn Code trên thì chạy với Excel2003 (với file của bạn Huuthang_bd gửi lên thì chạy rất ổn), nhưng sao khi mình chép vô vào Excel2007 thì lại không chạy được ạ? Mình xin gửi cả 2 file lên: 1 file là excel2003 do bạn Huuthang_bd giúp và 1 file là excel2007 mình đã chép đoạn code trên vào nhưng không chạy được, không biết nguyên do ở đâu, vì file cuối cùng mình cần sử dụng là excel2007 (do mình cần sử dụng số cột dữ liệu trong file lớn hơn 300 cột). Mong sự giúp đỡ của các bạn! Xin cảm ơn!

 

[huuthang_bd]

- GPE có thể xem giúp hộ mình trường hợp này với ạ! Với đoạn Code trên thì chạy với Excel2003 (với file của bạn Huuthang_bd gửi lên thì chạy rất ổn), nhưng sao khi mình chép vô vào Excel2007 thì lại không chạy được ạ? Mình xin gửi cả 2 file lên: 1 file là excel2003 do bạn Huuthang_bd giúp và 1 file là excel2007 mình đã chép đoạn code trên vào nhưng không chạy được, không biết nguyên do ở đâu, vì file cuối cùng mình cần sử dụng là excel2007 (do mình cần sử dụng số cột dữ liệu trong file lớn hơn 300 cột). Mong sự giúp đỡ của các bạn! Xin cảm ơn!

Sao bạn không lấy file đó Save as lại thành file 2007 cho khỏe. Copy code làm gì cho mất công mà lại sai.
Bạn copy Code qua file mới không chạy được là do CodeName của file bạn và CodeName file tôi khác nhau (File tôi CodeName sheet Result là Sheet7, của bạn là Sheet2).
Cách khắc phục: Sửa CodeName sheet Result lại là Sheet7 hoặc lấy file của tôi Save as thành Excel 2007

 

[pt_hcl]

Mình đã dựa vào code trên và sửa thêm code của bài này tăng lên trường hợp có thể ghép 100 dòng không biết như vậy có đúng không? Nhưng khi mình chép vô vào macro thì thấy báo đỏ chỗ khai báo, mình thấy báo là sai lỗi cú pháp nhưng không biết sai cú pháp ở chỗ nào mong các bạn chỉ giúp? Code như sau ạ:

Sub GPE()
Application.ScreenUpdating = False
Dim i As Long, Dong1 As Long, Dong2 As Long, Dong3 As Long, Dong4 As Long, Dong5 As Long, Dong6 As Long, Dong7 As Long, Dong8 As Long, Dong9 As Long, Dong10 As Long, Dong11 As Long, Dong12 As Long, Dong13 As Long, Dong14 As Long, Dong15 As Long, Dong16 As Long, Dong17 As Long, Dong18 As Long, Dong19 As Long, Dong20 As Long, Dong21 As Long, Dong22 As Long, Dong23 As Long, Dong24 As Long, Dong25 As Long, Dong26 As Long, Dong27 As Long, Dong28 As Long, Dong29 As Long, Dong30 As Long, Dong31 As Long, Dong32 As Long, Dong33 As Long, Dong34 As Long, Dong35 As Long, Dong36 As Long, Dong37 As Long, Dong38 As Long, Dong39 As Long, Dong40 As Long, Dong41 As Long, Dong42 As Long, Dong43 As Long, Dong44 As Long, Dong45 As Long, Dong46 As Long, Dong47 As Long, Dong48 As Long, Dong49 As Long, Dong50 As Long, Dong51 As Long, Dong52 As Long, Dong53 As Long, Dong54 As Long, Dong55 As Long, Dong56 As Long, Dong57 As Long, Dong58 As Long, Dong59 As Long, Dong60 As Long, Dong61 As Long, Dong62 As Long, Dong63 As Long, Dong64 As
Long, Dong65 As Long, Dong66 As Long, Dong67 As Long, Dong68 As Long, Dong69 As Long, Dong70 As Long, Dong71 As Long, Dong72 As Long, Dong73 As Long, Dong74 As Long, Dong75 As Long, Dong76 As Long, Dong77 As Long, Dong78 As Long, Dong79 As Long, Dong80 As Long, Dong81 As Long, Dong82 As Long, Dong83 As Long, Dong84 As Long, Dong85 As Long, Dong86 As Long, Dong87 As Long, Dong88 As Long, Dong89 As Long, Dong90 As Long, Dong91 As Long, Dong92 As Long, Dong93 As Long, Dong94 As Long, Dong95 As Long, Dong96 As Long, Dong97 As Long, Dong98 As Long, Dong99 As Long, Dong100 As Long
.....
Dim SoDong As Long, SoCot As Long
ActiveWorkbook.Names.Add Name:="Ghep", RefersTo:="=RngDong1+RngDong2" & IIf(SoDong >= 3, "+RngDong3", "") & IIf(SoDong >= 4, "+RngDong4", "") & IIf(SoDong >= 5, "+RngDong5", "") & IIf(SoDong >= 6 "+RngDong6", "") & IIf(SoDong >= 7, "+RngDong7", "") & IIf(SoDong >= 8, "+RngDong8", "") & IIf(SoDong >= 9 "+RngDong9", "") & IIf(SoDong >= 10, "+RngDong10", "") & IIf(SoDong >= 11, "+RngDong11", "") & IIf(SoDong >= 12, "+RngDong12", "") & IIf(SoDong >= 13, "+RngDong13", "") & IIf(SoDong >= 14, "+RngDong14", "") & IIf(SoDong >= 15, "+RngDong15", "") & IIf(SoDong >=16, "+RngDong16", "") & IIf(SoDong >= 17, "+RngDong17", "") & IIf(SoDong >= 18, "+RngDong18", "") & IIf(SoDong >= 19, "+RngDong19", "") & IIf(SoDong >= 20, "+RngDong20", "") & IIf(SoDong >= 21, "+RngDong21", "") & IIf(SoDong >= 22, "+RngDong22", "") & IIf(SoDong >= 23, "+RngDong23", "") & IIf(SoDong >= 24, "+RngDong24", "") & IIf(SoDong >= 25, "+RngDong25", "") & IIf(SoDong >=26, "+RngDong26", "") & IIf(SoDong >= 27, "+RngDong27", "") & IIf(SoDong >= 2
8, "+RngDong28", "") & IIf(SoDong >= 29, "+RngDong29", "") & IIf(SoDong >= 30, "+RngDong30", "") & IIf(SoDong >= 31, "+RngDong31", "") & IIf(SoDong >= 32, "+RngDong32", "") & IIf(SoDong >= 33, "+RngDong33", "") & IIf(SoDong >= 34, "+RngDong34", "") & IIf(SoDong >= 35, "+RngDong35", "") & IIf(SoDong >=36, "+RngDong36", "") & IIf(SoDong >= 37, "+RngDong37", "") & IIf(SoDong >= 38, "+RngDong38", "") & IIf(SoDong >= 39, "+RngDong39", "") & IIf(SoDong >= 40, "+RngDong40", "") & IIf(SoDong >= 41, "+RngDong41", "") & IIf(SoDong >= 42, "+RngDong42", "") & IIf(SoDong >= 43, "+RngDong43", "") & IIf(SoDong >= 44, "+RngDong44", "") & IIf(SoDong >= 45, "+RngDong45", "") & IIf(SoDong >=46, "+RngDong46", "") & IIf(SoDong >= 47, "+RngDong47", "") & IIf(SoDong >= 48, "+RngDong48", "") & IIf(SoDong >= 49, "+RngDong49", "") & IIf(SoDong >= 50, "+RngDong50", "") & IIf(SoDong >= 51, "+RngDong51", "") & IIf(SoDong >= 52, "+RngDong52", "") & IIf(SoDong >= 53, "+RngDong53", "") & IIf(SoDong >= 54, "+RngDong54", "") & IIf(SoDong >=
55, "+RngDong55", "") & IIf(SoDong >=56, "+RngDong56", "") & IIf(SoDong >= 57, "+RngDong57", "") & IIf(SoDong >= 58, "+RngDong58", "") & IIf(SoDong >= 59, "+RngDong59", "") & IIf(SoDong >= 60, "+RngDong60", "") & IIf(SoDong >= 61, "+RngDong61", "") & IIf(SoDong >= 62, "+RngDong62", "") & IIf(SoDong >= 63, "+RngDong63", "") & IIf(SoDong >= 64, "+RngDong64", "") & IIf(SoDong >= 65, "+RngDong65", "") & IIf(SoDong >=66, "+RngDong66", "") & IIf(SoDong >= 67, "+RngDong67", "") & IIf(SoDong >= 68, "+RngDong68", "") & IIf(SoDong >= 69, "+RngDong69", "") & IIf(SoDong >= 70, "+RngDong70", "") & IIf(SoDong >= 71, "+RngDong71", "") & IIf(SoDong >= 72, "+RngDong72", "") & IIf(SoDong >= 73, "+RngDong73", "") & IIf(SoDong >= 74, "+RngDong74", "") & IIf(SoDong >= 75, "+RngDong75", "") & IIf(SoDong >=76, "+RngDong76", "") & IIf(SoDong >= 77, "+RngDong77", "") & IIf(SoDong >= 78, "+RngDong78", "") & IIf(SoDong >= 79, "+RngDong79", "") & IIf(SoDong >=80, "+RngDong80", "") & IIf(SoDong >= 81, "+RngDong81", "") & IIf(SoDong >= 8
2, "+RngDong82", "") & IIf(SoDong >= 83, "+RngDong83", "") & IIf(SoDong >= 84, "+RngDong84", "") & IIf(SoDong >= 85, "+RngDong85", "") & IIf(SoDong >=86, "+RngDong86", "") & IIf(SoDong >= 87, "+RngDong87", "") & IIf(SoDong >= 88, "+RngDong88", "") & IIf(SoDong >= 89, "+RngDong89", "") & IIf(SoDong >= 90, "+RngDong90", "") & IIf(SoDong >= 91, "+RngDong91", "") & IIf(SoDong >= 92, "+RngDong92", "") & IIf(SoDong >= 93, "+RngDong93", "") & IIf(SoDong >= 94, "+RngDong94", "") & IIf(SoDong >= 95, "+RngDong95", "") & IIf(SoDong >= 96, "+RngDong96", "") & IIf(SoDong >= 97, "+RngDong97", "") & IIf(SoDong >= 98, "+RngDong98", "") & IIf(SoDong >= 99, "+RngDong99", "") & IIf(SoDong >= 100, "+RngDong100", "")
For Dong1 = StartR To EndR
.............

Mình đã tìm ra nguyên nhân rồi! Cảm ơn các bạ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 đỡ!