View Full Version : Combine text using loop
online
01-13-2011, 05:04 AM
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
01-13-2011, 07:53 AM
You can use concatenate command to get desired results OR & operator to get it done. I've provided the same in the grey columns.
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
01-13-2011, 09:51 AM
thank you so much GTO
exactly i want like this but i could not understan what is use of function here.
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
01-18-2011, 02:13 AM
Great!!! Thanx again for quick response
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.