Viết Code: xóa dòng trống, sau đó chèn thêm dòng mới dưới mỗi dòng và Copy dữ liệu (1 người xem)

[hngiatuong]

Mình muốn Xóa các dòng trống, sau đó chèn dưới mỗi dòng 1 dòng mới, rồi copy dữ liệu từ dòng trên xuống dòng vừa chèn. Xin cảm ơn.

 

[quocphuoc88]

Sub GPE()
Dim Sarr(), Arr(), i As Long, j As Long, Endr As Long, Dic As Object
Dim HoTen As String, DayDau As String, DayCuoi As String
With Sheet1
    If .AutoFilterMode Then .AutoFilterMode = False
    Endr = .Range("E65500").End(xlUp).Row
    If Endr > 2 Then
        Set Dic = CreateObject("Scripting.Dictionary")
        Sarr = .Range("C3:E" & Endr)
        For i = 1 To Endr - 2
            HoTen = Sarr(i, 3)
            DayDau = Left$(Sarr(i, 1), 6)
            DayCuoi = Right$(Sarr(i, 1), 3)
            If Not Dic.Exists(HoTen) Then
                Dic.Add HoTen, DayDau & "." & DayCuoi
            Else
                Dic.Item(HoTen) = Dic.Item(HoTen) & "." & DayCuoi
            End If
        Next i
        Sarr = Dic.keys
        ReDim Arr(1 To Dic.Count * 2, 1 To 2)
        For i = 1 To Dic.Count
            Arr(i + j, 1) = i + j
            Arr(i + j + 1, 1) = i + j + 1
            Arr(i + j, 2) = Dic.Item(Sarr(i - 1)) & "_(1)"
            Arr(i + j + 1, 2) = Dic.Item(Sarr(i - 1)) & "_(2)"
            j = j + 1
        Next i
        .Range("S7").Resize(Dic.Count * 2, 2).Value = Arr
        Set Dic = Nothing
    End If
End With
End Sub

Thử xem được chưa nha bạn !

 

[hngiatuong]

Thử xem được chưa nha bạn !

Cảm ơn anh. Đúng ý rồi đấy.
Như đoạn này DayDau = Left$(Sarr(i, 1), 6)
Nhưng nếu điều kiện: khi cột C là ..9 số thì lấy DayDau = 6 (như trên đúng rồi)
........................ và khi cột C là 10 số thì lấy DayDau = 7 (thêm ý này)thì sửa code thế nào.
Điều nữa là: Mình cần xóa cột kết quả cũ trước khi cập nhật kết quả mới (có thể cột KQ cũ dài hơn cột KQ mới)
.Range("S7").Resize(Dic.Count * 2, 2).Value = Arr
Và cuối cùng gán giúp vào 1 cái nút được không.

 

[chuot0106]

Sub GPE()
Dim Sarr(), Arr(), i As Long, j As Long, Endr As Long, Dic As Object
Dim HoTen As String, DayDau As String, DayCuoi As String
With Sheet1
    If .AutoFilterMode Then .AutoFilterMode = False
    Endr = .Range("E65500").End(xlUp).Row
    If Endr > 2 Then
        Set Dic = CreateObject("Scripting.Dictionary")
        Sarr = .Range("C3:E" & Endr)
        For i = 1 To Endr - 2
            HoTen = Sarr(i, 3)
            DayDau = Left$(Sarr(i, 1), 6)
            DayCuoi = Right$(Sarr(i, 1), 3)
            If Not Dic.Exists(HoTen) Then
                Dic.Add HoTen, DayDau & "." & DayCuoi
            Else
                Dic.Item(HoTen) = Dic.Item(HoTen) & "." & DayCuoi
            End If
        Next i
        Sarr = Dic.keys
        ReDim Arr(1 To Dic.Count * 2, 1 To 2)
        For i = 1 To Dic.Count
            Arr(i + j, 1) = i + j
            Arr(i + j + 1, 1) = i + j + 1
            Arr(i + j, 2) = Dic.Item(Sarr(i - 1)) & "_(1)"
            Arr(i + j + 1, 2) = Dic.Item(Sarr(i - 1)) & "_(2)"
            j = j + 1
        Next i
        .Range("S7").Resize(Dic.Count * 2, 2).Value = Arr
        Set Dic = Nothing
    End If
End With
End Sub

Thử xem được chưa nha bạn !

Liệu bài này dùng mảng có được không anh?

 

[quocphuoc88]

1. Do mình không biết chuẩn dãy số của bạn. Nếu bạn chỉ lấy 3 số cuối để ghép vào dãy đầu thì lúc này sẽ sữa lại là
DayDau = Left$(Sarr(i, 1), len(Sarr(i,1)-3)

2. Xóa kết quả củ: do mình không biết bạn sẽ gán kết quả vào chỗ nào . Ví dụ bán gán kết quả vào chỗ S7 thì trước khi gán dữ liệu xuống bạn thêm đoạn code này nó sẽ xóa dữ liệu cũ:
.Range("S7:T"&.Range("S65500").End(Xlup).Row).Clearcontents

3. Gán nút lệnh thì bạn chỉ Insert thêm 1 shapes nào đó rồi Assign cái macro này thôi

 

[hngiatuong]

1. Do mình không biết chuẩn dãy số của bạn. Nếu bạn chỉ lấy 3 số cuối để ghép vào dãy đầu thì lúc này sẽ sữa lại là:

Nếu nói về dãy số thì không thật là chuẩn (vì copy từ mạng xuống). Tuy nhiên ta coi là chuẩn, việc này ta xử lý trước để cho nó chuẩn ( có cả 2 loại dãy số: là 9 số, và là 10 số - có mặt cùng trong cột). Nếu là 9 thì dãy đầu lấy 6+ dãy cuối là 3 thêm dấu chấm như cũ là đúng, nếu là 10 thì dãy đầu lấy 7+dãy cuối. Nhưng thay DayDau = Left$(Sarr(i, 1), len(Sarr(i,1)-3).Range("S7:T"&.Range("S65500").End(Xlup).Row).Clearcontents vào nó cập nhật cả dãy đầu là 9 hoặc 10 luôn + dãy cuối (như vẫy là dãy đầu thừa 3 số phía cuối)

1.2. Xóa kết quả củ: do mình không biết bạn sẽ gán kết quả vào chỗ nào . Ví dụ bán gán kết quả vào chỗ S7 thì trước khi gán dữ liệu xuống bạn thêm đoạn code này nó sẽ xóa dữ liệu cũ:

Gán chỗ nào thì mình làm được. Nhưng gán .Range("S7:T"&.Range("S65500").End(Xlup).Row).Clearcontents thì nó báo lỗi. Chưa hiểu vì sao.

 

[quocphuoc88]

1. Bạn nói thừa là sao thì mình chưa hiểu. Bạn đưa file dử liệu của bạn lên đi
2. Chổ báo lỗi xóa dữ liệu thì mình quên thêm điều kiện kiểm tra dòng cuối. Bạn cứ đưa file lên đi mình làm hoàn chỉnh luôn !

 

[hngiatuong]

Bạn nói thừa là sao thì mình chưa hiểu. Bạn đưa file dử liệu của bạn lên đi

 

[quocphuoc88]

thử xem ok chưa nhé bạn !

 

[hngiatuong]

thử xem ok chưa nhé bạn !

Cảm ơn bạn nhé. Hiện tại chưa phát hiện ra lỗi, chỉ gặp lỗi khi có 1 dòng nào đó là tập rỗng(điều này không quan trọng). OK rồi đấy.