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