اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

  • تمت الإجابة
قام بنشر
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

 

  • Like 4
قام بنشر

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

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

 

  • Like 3

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information