Nhờ viết Code "tách, nhập chuỗi" (1 người xem)

[kieuhuy_bmt]

Tôi đang loay hoay vấn đề như sau:
Có dữ liệu ở hai cột Ví dụ cột A là AH56781 - cột b là AH56783
bây giờ muốn
1.Tách chúng ra thành những hàng chi tiết sang cột F
liều nhau là: AH56781
AH56782
AH56783
2. Làm nhập ngược lại như ban đầu:
(Chi tiết nhờ mọi người xem File)
Do dữ liệu nhiều nền nhờ Diễn đàn, anh chị viết tặng tôi 1 Code để chạy. Tôi xin cảm ơn!

 

[concogia]

Tôi đang loay hoay vấn đề như sau:
Có dữ liệu ở hai cột Ví dụ cột A là AH56781 - cột b là AH56783
bây giờ muốn
1.Tách chúng ra thành những hàng chi tiết sang cột F
liều nhau là: AH56781
AH56782
AH56783
2. Làm nhập ngược lại như ban đầu:
(Chi tiết nhờ mọi người xem File)
Do dữ liệu nhiều nền nhờ Diễn đàn, anh chị viết tặng tôi 1 Code để chạy. Tôi xin cảm ơn!

Muốn tặng code thì....tặng code ( code viết thôi mà, đâu có mất mát gì đâu, hihi )
Đói bụng quá, chưa kiểm tra hết các tình huống, bạn làm giúp chuyện này nhé
Thò anh tý bấm cái nút có chữ "Xuoi" ==> kết quả nằm ở sheet "Xuoi" cho đỡ rối mắt
Ở sheet "Xuoi" lại thò anh tý bấm vào cái mũi tên ==> Kết quả ở kế bên
Hihi, cái bảng của bạn nhiều màu & có mấy cái vòng xanh xanh đỏ đỏ .....đẹp thật
Híc

 

[kieuhuy_bmt]

Cảm ơn bác CCG. Bác lúc nào cũng có mặt và tận tình giúp mọi người.
Gủi lại anh em cái File, nhờ mọi người giúp luôn vì khi xuất chi tiết nó mất một ký tự "0" sau chữ cái.

 

[concogia]

Cảm ơn bác CCG. Bác lúc nào cũng có mặt và tận tình giúp mọi người.
Gủi lại anh em cái File, nhờ mọi người giúp luôn vì khi xuất chi tiết nó mất một ký tự "0" sau chữ cái.

Nếu chắc chắn chỉ 1 số 0 đó thì bạn chép cái này đè lên code "Xuoi" cũ giúp mình

Public Sub Xuoi()
    Dim Vung, Ws, CoRe, Mg, So, Chu, I, J, K, Tong
    Set CoRe = CreateObject("VBScript.RegExp")
    Vung = Range([B3], [B50000].End(xlUp)).Resize(, 4)
        For I = 1 To UBound(Vung)
            Tong = Tong + Vung(I, 3)
        Next I
            ReDim Mg(1 To Tong, 1 To 3)
            For I = 1 To UBound(Vung)
                With CoRe
                    .Global = True
                    .Pattern = "[\D]"
                    So = .Replace(Vung(I, 1), "")
                    Chu = Replace(Vung(I, 1), So, "")
                End With
                For J = 0 To Vung(I, 3) - 1
                    K = K + 1
                    Mg(K, 1) = J + 1: Mg(K, 3) = Vung(I, 4)
                    Mg(K, 2) = IIf(Left(So, 1) = "0", Chu & "0" & So + J, Chu & So + J)
                Next J
        Next I
        With Sheets("Xuoi")
            .[A4:C1000].ClearContents
            .[A4].Resize(K, 3) = Mg
        End With
End Sub

Thật ra với những bài dạng này bạn cố gắng đưa cấu trúc dữ liệu & yêu cầu thật đầy đủ thì hy vọng làm xong đỡ .....phải sửa
Thân

 

[hoangvuluan]

Thêm 1 cách "củ chuối", thao tác trực tiếp (chưa kiểm tra với dữ liệu lớn)

Public Sub Xuoi()
    Dim Vung, I, K, X, Tong
    Dim sh As Worksheet
    Vung = Range([B3], [B50000].End(xlUp)).Resize(, 4)
    X = UBound(Vung)
        For I = 1 To X
            Tong = Tong + Vung(I, 3)
        Next I
    Set sh = Sheets("Xuoi")
    With sh
        .[A4:C1000].ClearContents
        K = 4
        For I = 1 To X
            .Cells(K, 1) = 1
            .Cells(K, 2) = Vung(I, 1)
            .Cells(K, 3) = Vung(I, 4)
            If Vung(I, 3) > 1 Then _
                .Range(.Cells(K, 1), .Cells(K, 3)).AutoFill _
                Destination:=.Range(.Cells(K, 1), .Cells(K + Vung(I, 3) - 1, 3)), Type:=xlFillSeries
            K = K + Vung(I, 3)
        Next I
    End With
End Sub

>>> To: Bác concogia: Bác kiểm tra lại code "nguoc" với trường hợp chỉ có 1 dòng dữ liệu.

 

[kieuhuy_bmt]

Dữ liệu cụ thể đây. Nhờ các anh chị xem trong File

Cảm ơn mọi người. Trong File gửi kèm, là cái kết quả cuối cùng mà tôi cần báo cáo. Tức là khi ai hỏi đến "cái bìa đỏ kia nhập ngày nào và xuất cho ai, ngày nào". Mày mò từng khúc không ra sao nên pos lên nhờ tất tần tật để mọi người có phương án nào nhanh và chính xác. Kính mong mọi người giúp.

 

[kieuhuy_bmt]

Bác CCG ơi!

Thật ra với những bài dạng này bạn cố gắng đưa cấu trúc dữ liệu & yêu cầu thật đầy đủ thì hy vọng làm xong đỡ .....phải sửa
Thân

Bác bớt chút thời giờ vàng ngọc của mình tiếp tục giúp tôi với.