پرسش ترکیب چند ستون مختلف تکست به کمک vba

[Z.Ruzbeh]

سلام . روز همگی بخیر
من میخوام چند تا ستون رو با هم ترکیب کنم و در یک شیت جدید بنویسم
فرض کنید دارم یک برنامه زمانبندی برای یک پروژه ساختمانی تهیه میکنم که شامل 4 گود ساختمانی هست. ما در هر مرحله 2 متر حفاری میکنیم و هر گود شامل چهار ضلع می شود که آنها را با کمک سیستم نیلینگ مهار میکنیم و مراحل اجرا در ستون دیگر ذکر شده است . با چه کد هایی میتونم این روند رو سریعتر انجام بدم و آیا تابعی در اکسل پیدا میشود که به صورت اتومات این ترکیب را انجام بدهم ؟ فایل مربوطه را در پیوست قرار میدم پیشاپیش از همکاری شما سپاسگذارم
WBS.xlsx

[iranweld]

با سلام

در صورتیکه دیتای ستون های اول را کامل بنویسید فایل پیوست را بررسی کنید

[Z.Ruzbeh]

سلام . ممنون از پاسختون . دستور concatenate رو میشه به کار برد ولی خیلی بازم باید نوشت .. این برنامه در حدود 800 سطر میشه که از حوصله خارج هست . چطور میشه با دستور for و next یه کد نوشت ؟کلا نمیشه کد vba زد واسش؟
مثلا چندتا متغیر تعیریف کرد بعد با لوپ سطر ها رو نوشت ؟
sub combination()
a=1
b=1
c=1
d=1
x=1
for x=1 to 800
next

[iranweld]

فایل پیوست را بررسی کنید

Sub Macro1()
        Range("C3").Select        z1 = Cells(Rows.Count, "d").End(xlUp).Row        For j = 3 To z1          Selection.End(xlDown).Select
    xx = ActiveCell.Row        For i = 3 To xx - 1        x1 = Cells(i, 1).Offset(0, 0).End(xlUp)         x2 = Cells(i, 1).Offset(, 1).End(xlUp)       x3 = Cells(i, 1).Offset(, 2).End(xlUp)        x4 = Cells(i, 4)        If x4 <> "" Then        Range("e" & i) = x1 & " " & x2 & " " & x3 & " ، " & x4        Else        Range("e" & i) = ""            End If        If i >= z1 Then Exit For            Next        If i >= z1 Then Exit For            Next        Range("e3").Select    End Sub 

[Z.Ruzbeh]

فایل پیوست را بررسی کنید

Sub Macro1()
        Range("C3").Select        z1 = Cells(Rows.Count, "d").End(xlUp).Row        For j = 3 To z1          Selection.End(xlDown).Select
    xx = ActiveCell.Row        For i = 3 To xx - 1        x1 = Cells(i, 1).Offset(0, 0).End(xlUp)         x2 = Cells(i, 1).Offset(, 1).End(xlUp)       x3 = Cells(i, 1).Offset(, 2).End(xlUp)        x4 = Cells(i, 4)        If x4 <> "" Then        Range("e" & i) = x1 & " " & x2 & " " & x3 & " ، " & x4        Else        Range("e" & i) = ""            End If        If i >= z1 Then Exit For            Next        If i >= z1 Then Exit For            Next        Range("e3").Select    End Sub 

خوب عمل نمیکنه ... ما باید یه کدی بنویسیم که فقط وابسته به ستون های G تا J باشه .. اون قسمت ستون های A تا E رو بنده فقط واسه نمایش نتیجه مطلوب گذاشتم
این کد رو تو نت پیدا کردم کارمو راه انداخت ..ممنون از شرکت کنندگان در موضوع

'For 4 Columns

Sub combinations2()

    Dim c1() As Variant
    Dim c2() As Variant
    Dim c3() As Variant
    Dim c4() As Variant

    Dim out() As Variant
    Dim j As Long, k As Long, l As Long, m As Long, n As Long


    Dim col1 As Range
    Dim col2 As Range
    Dim col3 As Range
    Dim col4 As Range

    Dim out1 As Range


    Set col1 = Range("A1", Range("A1").End(xlDown))
    Set col2 = Range("B1", Range("B1").End(xlDown))
    Set col3 = Range("C1", Range("C1").End(xlDown))
    Set col4 = Range("D1", Range("D1").End(xlDown))

    c1 = col1
    c2 = col2
    c3 = col3
    c4 = col4

    Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4)))
    out = out1

    j = 1
    k = 1
    l = 1
    m = 1
    n = 1


    Do While j <= UBound(c1)
        Do While k <= UBound(c2)
            Do While l <= UBound(c3)
                Do While m <= UBound(c4)
                    out(n, 1) = c1(j, 1)
                    out(n, 2) = c2(k, 1)
                    out(n, 3) = c3(l, 1)
                    out(n, 4) = c4(m, 1)
                    n = n + 1
                    m = m + 1
                Loop
                m = 1
                l = l + 1
            Loop
            l = 1
            k = k + 1
        Loop
        k = 1
        j = j + 1
    Loop


    out1.Value = out
End Sub 

فقط کسی میتونه کد Ubound رو توضیح بده عملکردش چیه؟ کلا یه توضیحی روی این کد بدین ماهم بفهمیم

[Z.Ruzbeh]

این دوتا کد هم پیدا کردم

'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()

    Dim rv() As String
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long
    Dim numIn As Long, s As String, r As Long

    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)
    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i
    ReDim rv(0 To t - 1) 'resize destination array

    For n = 0 To (t - 1)
        s = ""
        For i = 1 To numIn
            s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
        Next i
        rv(n) = s

        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n

    Combine = rv
End Function 

'Here 's a generic approach which should work for any number of columns/values (within reason):

Sub ListCombinations()

Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long

    Set sht = ActiveSheet
    For Each c In sht.Range("A1:D1").Cells
        col.add Application.Transpose(sht.Range(c, c.End(xlDown)))
        numCols = numCols + 1
    Next c

    res = Combine(col, "~~")

    For i = 0 To UBound(res)
        arr = Split(res(i), "~~")
        sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
    Next i

End Sub