Combine text using loop

[online]

Hi guys,

I have a sheet in which i want to combine text each 2nd rows with ; in column "A" and 1st, 2nd, 3rd and forth rows in column "B" same as Column "C", i have attached the sheet in which "sheet4" is data and i want result like in Sheet "Sample".please help me really i will appreciate him.

[shrivallabha]

You can use concatenate command to get desired results OR & operator to get it done. I've provided the same in the grey columns.

[GTO]

Hi there,

I'm not sure exactly how you want it to layout or where, but hope this is close enough to adjust-to-suit.

Option Explicit
    
Sub exa()
Dim _
lRow            As Long, _
i               As Long, _
ii              As Long, _
iii             As Long, _
x               As Long, _
wksBefore       As Worksheet, _
wksAfter        As Worksheet, _
wks             As Worksheet, _
shName          As String, _
strTemp         As String, _
aryTransposed   As Variant
    
    Set wksBefore = ActiveSheet
        
    Do
        If ShExists(shName) Then Set wks = ThisWorkbook.Worksheets(shName)
        i = i + 1
        shName = "Sample_" & Format(i, "000")
    Loop While ShExists(shName)
    
    If Not wks Is Nothing Then
        Set wksAfter = ThisWorkbook.Worksheets.Add(After:=wks, Type:=xlWBATWorksheet)
    Else
        Set wksAfter = ThisWorkbook.Worksheets.Add(After:=wksBefore, Type:=xlWBATWorksheet)
    End If
    
    wksAfter.Name = shName
    lRow = wksBefore.Cells(wksBefore.Rows.Count, 1).End(xlUp).Row
    If lRow < 8 Then Exit Sub
    
    ReDim aryTransposed(1 To 3, 0 To 0)
    
    With wksBefore
        For i = 6 To lRow Step 5
            x = x + 1
            ReDim Preserve aryTransposed(1 To 3, 1 To UBound(aryTransposed, 2) + 1)
            strTemp = vbNullString
            If Not .Cells(i, 1).Value = vbNullString Then
                strTemp = .Cells(i, 1).Value & "; "
            End If
            If Not .Cells(i + 2, 1).Value = vbNullString Then
                strTemp = strTemp & .Cells(i + 2, 1)
            End If
            aryTransposed(1, x) = strTemp
            
            strTemp = vbNullString
            For ii = i To i + 3
                If Not .Cells(ii, "D").Value = vbNullString Then
                    strTemp = strTemp & .Cells(ii, "D").Value & Chr(32)
                End If
            Next
            aryTransposed(2, x) = strTemp
            
            strTemp = vbNullString
            For iii = i To i + 2
                If Not .Cells(iii, "G").Value = vbNullString Then
                    strTemp = strTemp & .Cells(iii, "G") & Chr(32)
                End If
            Next
            aryTransposed(3, x) = strTemp
        Next
    End With
    
    wksAfter.Range("A2").Resize(UBound(aryTransposed, 2), _
                                UBound(aryTransposed, 1)).Value _
                                    = Application.Transpose(aryTransposed)
    With wksAfter.Range("A1:C1")
        .Value = Array("Company Name", "Address", "Phone/FAX")
        .Font.Bold = True
        .EntireColumn.AutoFit
    End With
End Sub
    
Function ShExists(shName As String, _
                  Optional WB As Workbook, _
                  Optional CheckCase As Boolean = False) As Boolean
    
    If WB Is Nothing Then
        Set WB = ThisWorkbook
    End If
    
    If CheckCase Then
        On Error Resume Next
        ShExists = CBool(WB.Worksheets(shName).Name = shName)
        On Error GoTo 0
    Else
        On Error Resume Next
        ShExists = CBool(UCase(WB.Worksheets(shName).Name) = UCase(shName))
        On Error GoTo 0
    End If
End Function

Hope that helps,

Mark

[online]

thank you so much GTO
exactly i want like this but i could not understan what is use of function here.

[GTO]

thank you so much GTO
exactly i want like this but i could not understan what is use of function here.

You are very welcome. I wasn't sure if you meant the procedures as a whole, or just the function called, so here is the code all commented.

Please note that I changed a small bit. Due to OBBS*, I had the code creating the destination sheet before cecking to see if there is data to send. I changed this around...

Option Explicit
    
Sub exa()
Dim _
lRow            As Long, _
i               As Long, _
ii              As Long, _
iii             As Long, _
x               As Long, _
wksBefore       As Worksheet, _
wksAfter        As Worksheet, _
wks             As Worksheet, _
shName          As String, _
strTemp         As String, _
aryTransposed   As Variant
    
    '// Change to suit                                                                  //
    Set wksBefore = ActiveSheet
    '// Find the last row in Col A with data                                            //
    lRow = wksBefore.Cells(wksBefore.Rows.Count, 1).End(xlUp).Row
    '// If we do not have at least one complete record, bail here.  Just a simple       //
    '// 'safety.'                                                                       //
    If lRow < 8 Then Exit Sub
    
    '// See the Function.  We're creating a new sheet to hold the coerced records.      //
    '// We'll ensure we don't try and name the new sheet the same as an existing one.   //
    Do
        If ShExists(shName) Then Set wks = ThisWorkbook.Worksheets(shName)
        i = i + 1
        shName = "Sample_" & Format(i, "000")
    Loop While ShExists(shName)
    
    '// If we found any prior created sheets, we'll position our new one after the most //
    '// recent one.  Else, after our input sheet.                                       //
    If Not wks Is Nothing Then
        Set wksAfter = ThisWorkbook.Worksheets.Add(After:=wks, Type:=xlWBATWorksheet)
    Else
        Set wksAfter = ThisWorkbook.Worksheets.Add(After:=wksBefore, Type:=xlWBATWorksheet)
    End If
    
    wksAfter.Name = shName
    
    '// We'll use a 1-based array, so we'll initialize the 2nd dimiension at a zero base//
    '// and move it up to one in the first loop... to prevent having an empty element   //
    '// later.                                                                          //
    ReDim aryTransposed(1 To 3, 0 To 0)
    
    With wksBefore
        '// FROM the first row with a record... Stepping by 5 of course means the sheet //
        '// MUST be layed out consistently.                                             //
        For i = 6 To lRow Step 5
            '// x is a counter for our array.                                           //
            x = x + 1
            '// Note that we jumped the base up to one in the 2nd dimension.  So, the   //
            '// first time thru, it'll end up (1 To 3, 1 To 1), the second loop:        //
            '// (1 To 3, 1 To 2) and so on.                                             //
            ReDim Preserve aryTransposed(1 To 3, 1 To UBound(aryTransposed, 2) + 1)
            '// Start ea loop w/an empty string.                                        //
            strTemp = vbNullString
            '// Check ea cell before adding to the string, so we don't end up with      //
            '// just semi-colons or spaces in the advent of any empty cells.            //
            If Not .Cells(i, 1).Value = vbNullString Then
                strTemp = .Cells(i, 1).Value & "; "
            End If
            If Not .Cells(i + 2, 1).Value = vbNullString Then
                strTemp = strTemp & .Cells(i + 2, 1)
            End If
            aryTransposed(1, x) = strTemp
            
            strTemp = vbNullString
            For ii = i To i + 3
                If Not .Cells(ii, "D").Value = vbNullString Then
                    strTemp = strTemp & .Cells(ii, "D").Value & Chr(32)
                End If
            Next
            aryTransposed(2, x) = strTemp
            
            strTemp = vbNullString
            For iii = i To i + 2
                If Not .Cells(iii, "G").Value = vbNullString Then
                    strTemp = strTemp & .Cells(iii, "G") & Chr(32)
                End If
            Next
            aryTransposed(3, x) = strTemp
        Next
    End With
    
    '// Transpose the array and plunk it into the destination sheet.                    //
    wksAfter.Range("A2").Resize(UBound(aryTransposed, 2), _
                                UBound(aryTransposed, 1)).Value _
                                    = Application.Transpose(aryTransposed)
    '// Prettify...//
    With wksAfter.Range("A1:C1")
        .Value = Array("Company Info", "Address", "Phone/FAX")
        .Font.Bold = True
        .EntireColumn.AutoFit
    End With
End Sub
    
Function ShExists(shName As String, _
                  Optional WB As Workbook, _
                  Optional CheckCase As Boolean = False) As Boolean
    
    '// If we included passing a specific workbook ByRef, that will be the workbook     //
    '// that we are checking.  But if we left the arg out, then we presume we are       //
    '// checking ThisWorkbook, and set a reference to it.                               //
    If WB Is Nothing Then
        Set WB = ThisWorkbook
    End If
    
    '// CheckCase is simply to see if we want to specifically check the Case of ea sheet's//
    '// name.  You cannot have one sheet named "SHEET2" and another named "Sheet2", as      //
    '// the tab names are read case-insensitive.  So we'd really only care about case if we //
    '// were cleaning up formatting most likely.                                            //
    If CheckCase Then
        '// Allow the next command to error without faulting, to allow for NOT finding a sheet//
        '// If CBool(WB.Worksheets(shName).Name = shName) fails, ShExists simply stays FALSE,//
        '// then we reset error handling immedietely, so we don't mask errors elsewhere...  //
        On Error Resume Next
        ShExists = CBool(WB.Worksheets(shName).Name = shName)
        On Error GoTo 0
    Else
        On Error Resume Next
        ShExists = CBool(UCase(WB.Worksheets(shName).Name) = UCase(shName))
        On Error GoTo 0
    End If
End Function

Hope that helps,

Mark

OBBS = Occasional Blonde Brain Syndrome

[online]

Great!!! Thanx again for quick response