مساعدة في تحويل صفوف الى أعمدة دفعة واحدة حسب ما هو موضح في الصورة ثم تحويل الملف إلى ملف نصي

[ahmed040473]

السلام عليكم نرجو من الأخوة الكرام المساعدة في تحويل صفوف إلى اعمد دفعة واحدة حسب ما هو موضح في الصورة مع العلم أن عدد الصفوف كبير جدا ثم تحويل الملف إلى ملف نصي وشكر جزيلا

بيانات.xlsx

[lionheart]

Sub Test()
    Dim a, vArray(), sOut As String, i As Long, ii As Long, k As Long
    Application.ScreenUpdating = False
        a = Range("A2").CurrentRegion.Value
        ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
        For i = LBound(a, 1) To UBound(a, 1)
            For ii = LBound(a, 2) To UBound(a, 2)
                k = k + 1
                b(k, 1) = a(i, ii)
            Next ii
        Next i
        Columns("G").ClearContents
        Range("G2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
        vArray = Application.Transpose(b)
        sOut = Join(vArray, vbCrLf)
        Open ThisWorkbook.Path & "\Output.txt" For Output As #1
        Print #1, sOut
        Close #1
    Application.ScreenUpdating = True
    MsgBox "Done...", 64, "LionHeart"
End Sub

 

[محمد حسن المحمد]

ما شاء الله بارك الله

كود رائع أخي الكريم @lionheart

زادكم الله علماً وحلماً آمين يا ربّ العالمين.

[ahmed040473]

رائع شكرا جزيلا

[محي الدين ابو البشر]

ممكن خيار آخر؟ بعد اذنكم

Sub test2()
Dim a As Variant
Dim i As Long
    a = Cells(2.1).CurrentRegion
    Columns("H").ClearContents
    For i = 2 To UBound(a)
        Cells(Cells(Rows.Count, 8).End(xlUp).Row + 1, 8).Resize(4) = Application.Transpose(Application.Index(a, i, Array(1, 2, 3, 4)))
    Next
End Sub

Sub test2()
    Dim a As Variant
    Dim i As Long
    Columns("H").ClearContents
    a = Cells(2.1).CurrentRegion
    For i = 2 To UBound(a)
        b = IIf(b <> "", b & vbCrLf & Join(Application.Index(a, i, x), vbCrLf), _
                Join(Application.Index(a, i, Application.Transpose(Evaluate("row(1:" & UBound(a, 2) & ")"))), vbCrLf))
    Next
    Cells(2, 9).Resize((UBound(a) - 1) * UBound(a, 2)) = Application.Transpose(Split(b, vbCrLf))
    Open ThisWorkbook.Path & "\MOutput.txt" For Output As #1
    Print #1, b
    Close #1
End Sub