write at exceltoexplore@gmail.com : Report Automation|Dashboard in Excel| Provide Excel consulting through macro (VBA) automation |Financial Modeling | Ethical Hacking

Sunday, 12 June 2011

Find columns Names And CONCATENATE with quama separated

Excel vb does not provides a function called Application.WorksheetFunction.CONCATENATE
If you want to find particular columns and combine the contents of columns cells with quama separated.you can use below vb code
For instance, let's say you wanted to Find columns with header FirstName,MiddleName,LastName,Product and add together the contents of columns cells,
separate them by a quama,if your last column contain blank rows or its blank, the formula will be drag till end of column.
All you need to do is put the below code in vb module.Run the Macro.
New column "Concatcolumns" will be added to your data at end of columns. with concatenation of columns mention and quama separated

Dim r, rng, c As String
Dim LR As Long
Dim Found1, Found2, Found3, Found4 As Range
Dim lastcol, delcol As Long
'code by : Mahesh Parab
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For delcol = lastcol To 1 Step -1
If Cells(1, delcol) = "Concatcolumns" Then _
     Cells(1, delcol).EntireColumn.Delete
Set Found1 = Rows(1).Find(what:="FirstName", LookIn:=xlValues, lookat:=xlWhole)
Set Found2 = Rows(1).Find(what:="MiddleName", LookIn:=xlValues, lookat:=xlWhole)
Set Found3 = Rows(1).Find(what:="LastName", LookIn:=xlValues, lookat:=xlWhole)
Set Found4 = Rows(1).Find(what:="Product", LookIn:=xlValues, lookat:=xlWhole)
Cells(1, Columns.Count).End(xlToLeft).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Concatcolumns"
ActiveCell.Offset(1, 0).Select
c = "&"",""&"
ActiveCell.Value = "=" & Found1.Offset(1, 0).Address(False, False) & c & Found2.Offset(1, 0).Address(False, False) & _
c & Found3.Offset(1, 0).Address(False, False) & c & Found4.Offset(1, 0).Address(False, False)
r = Split(ActiveCell.Address, "$")(1)
rng = (":" & r)
LR = Cells(Rows.Count, "A").End(xlUp).Row
Selection.AutoFill Destination:=Range(r & ActiveCell.Row & rng & LR)
End Sub

No comments:

Post a Comment