VBA Ninja Needed - Concatenate Problem *Code included*

L

LNG2013

Active Member
Joined
May 23, 2011
Messages
466
:eeek: HELP!!!

I have run into a bit of an issue with part of my VBA code…

<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
What it does:

1.) Looks at a data file that has been received from a device, a .csv file.
2.) It creates a new workbook, and then copies the info from the csv to the file.
3.) It renames a row
4.) Generates a month and year based on a column
5.) Concatenates several columns into one column:warning:
6.) It then deletes some unneeded columns
7.) It then saves data to a folder and closes the application


<o:p></o:p>
:warning:My problem is with the concatenate part…

The code currently is only concatenating the data for the first row, and then duplicating it down.
Also, and here is the real kicker it is not just duplicating it for the rows that have data, it is going all the way down to the very last cell in the sheet…:confused:
The output file should be 2K and now it is around 11MB!!!


What it Should do:

It should be searching for particular columns (ProdCode, ClientCode, Type, SubType, Month, Week, Year). Note my columns change order at times.
It should then take the data in each row of each column and concatenate it together in it's corresponding row, in a new column named Combo. Each value is seperated by a comma.

Here's a sample of what it should look like.
ProdCode,ClientCode,Type,SubType,Month,Week,Year
1174,EVAN11,3,A,5,1,11

<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
<o:p>Here is my full code with sample data:</o:p>
https://rapidshare.com/files/401327348/EXCEL-MACRO.zip


Here is the code for the Concatenate section:<o:p> </o:p>
<o:p></o:p>
<o:p></o:p>
<o:p>
Code: 
 </o:p>
<o:p>
<o:p>Sub Combo()</o:p>
<o:p></o:p>
<o:p>Dim Found1, Found2, Found3, Found4, Found5, Found6, Found7 As Range
Dim lastcol, delcol As Long
Dim Temp1, Temp2 As String
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For delcol = lastcol To 1 Step -1
If Cells(1, delcol) = "Combo" Then _
     Cells(1, delcol).EntireColumn.Delete
Next
Set Found1 = Rows(1).Find(what:="ProdCode", LookIn:=xlValues, lookat:=xlWhole)
Set Found2 = Rows(1).Find(what:="ClientCode", LookIn:=xlValues, lookat:=xlWhole)
Set Found3 = Rows(1).Find(what:="Type", LookIn:=xlValues, lookat:=xlWhole)
Set Found4 = Rows(1).Find(what:="SubType", LookIn:=xlValues, lookat:=xlWhole)
Set Found5 = Rows(1).Find(what:="Month", LookIn:=xlValues, lookat:=xlWhole)
Set Found6 = Rows(1).Find(what:="Week", LookIn:=xlValues, lookat:=xlWhole)
Set Found7 = Rows(1).Find(what:="Year", LookIn:=xlValues, lookat:=xlWhole)
Cells(1, Columns.Count).End(xlToLeft).Select
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Combo"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Evaluate(Found1.Offset(1, 0).Address(False, False) & "& "","" & " & Found2.Offset(1, 0).Address(False, False) _
& "& "","" & " & Found3.Offset(1, 0).Address(False, False) & "& "","" & " & Found4.Offset(1, 0).Address(False, False) _
& "& "","" & " & Found5.Offset(1, 0).Address(False, False) & "& "","" & " & Found6.Offset(1, 0).Address(False, False) _
& "& "","" & " & Found7.Offset(1, 0).Address(False, False))</o:p>
<o:p>Temp1 = ActiveCell.Address
ActiveCell.Offset(1, -1).Select
Selection.End(xlDown).Select
Temp2 = ActiveCell.Offset(0, 1).Address
Range(Temp1 & ":" & Temp2).Select
Selection.FillDown
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
       :=False, Transpose:=False
    Application.CutCopyMode = False
    End Sub</o:p>
<o:p></o:p>


</o:p><o:p></o:p>
<o:p></o:p>
Thank you to all of the forums members who have helped me put together this code!​
<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
here's one way...

In a module try:
Code: 
Sub foo()

Dim Found1 As Long, Found2 As Long, Found3 As Long, Found4 As Long, Found5 As Long, Found6 As Long, Found7 As Long
Dim lastcol As Long, delcol As Long, lastrow As Long, i As Long
Dim Temp1 As String, Temp2 As String

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

With ActiveSheet

lastcol = Last(2, .Cells)
lastrow = Last(1, .Cells)

For delcol = lastcol To 1 Step -1
    If .Cells(1, delcol) = "Combo" Then .Cells(1, delcol).EntireColumn.Delete
Next

Found1 = FindColumn("ProdCode")
Found2 = FindColumn("ClientCode")
Found3 = FindColumn("Type")
Found4 = FindColumn("SubType")
Found5 = FindColumn("Month")
Found6 = FindColumn("Week")
Found7 = FindColumn("Year")

.Cells(1, lastcol + 1).Value = "combo"

For i = 2 To lastrow
    .Cells(i, lastcol + 1).Value = .Cells(i, Found1) & "," & .Cells(i, Found2) & "," & .Cells(i, Found3) & "," & .Cells(i, Found4) & "," & .Cells(i, Found5) & "," & .Cells(i, Found6) & "," & .Cells(i, Found7)
Next i

End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub


you also need these two functions:

Code: 
Function Last(choice As Long, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
    Dim lrw As Long
    Dim lcol As Long

    Select Case choice

    Case 1:
        On Error Resume Next
        Last = rng.Find(what:="*", _
                        After:=rng.Cells(1), _
                        lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        On Error GoTo 0

    Case 2:
        On Error Resume Next
        Last = rng.Find(what:="*", _
                        After:=rng.Cells(1), _
                        lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

    Case 3:
        On Error Resume Next
        lrw = rng.Find(what:="*", _
                       After:=rng.Cells(1), _
                       lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        lcol = rng.Find(what:="*", _
                        After:=rng.Cells(1), _
                        lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            Last = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0

    End Select
End Function

Function FindColumn(cName As String)
Dim r As Range
Dim lc As Long
Dim c As Long

lc = Last(2, ActiveSheet.Cells)
Set r = Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, lc))


        c = r.Find(what:=cName, After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, _
        lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Column
        FindColumn = c
End Function

also, your rapidshare link didn't work for me. The code I posted above worked on my test sheet, but couldn't test it against your example. Also, you could speed it up by changing this part:

Code: 
For i = 2 To lastrow
    .Cells(i, lastcol + 1).Value = .Cells(i, Found1) & "," & .Cells(i, Found2) & "," & .Cells(i, Found3) & "," & .Cells(i, Found4) & "," & .Cells(i, Found5) & "," & .Cells(i, Found6) & "," & .Cells(i, Found7)
Next i

to create a worksheet formula that concatenates the values together and then copies that down.
 
Last edited:
Upvote 0
Now with less looping!

Code: 
Sub foo()

Dim Found1 As Long, Found2 As Long, Found3 As Long, Found4 As Long, Found5 As Long, Found6 As Long, Found7 As Long
Dim lastcol As Long, delcol As Long, lastrow As Long, i As Long
Dim Temp1 As String, Temp2 As String

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

With Sheet1

lastcol = Last(2, .Cells)
lastrow = Last(1, .Cells)

For delcol = lastcol To 1 Step -1
    If .Cells(1, delcol) = "Combo" Then .Cells(1, delcol).EntireColumn.Delete
Next

Found1 = FindColumn("ProdCode")
Found2 = FindColumn("ClientCode")
Found3 = FindColumn("Type")
Found4 = FindColumn("SubType")
Found5 = FindColumn("Month")
Found6 = FindColumn("Week")
Found7 = FindColumn("Year")

.Cells(1, lastcol + 1).Value = "combo"

.Cells(2, lastcol + 1).FormulaR1C1 = "=RC" & Found1 & "& "","" & RC" & Found2 & "& "","" & RC" & Found3 & "& "","" & RC" & Found4 & "& "","" & RC" & Found5 & "& "","" & RC" & Found6 & "& "","" & RC" & Found7
.Cells(2, lastcol + 1).AutoFill Destination:=Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1))

Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Calculate
Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Value = Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Value

End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Don't forget the 2 functions I posted earlier.
 
Upvote 0
First, as an aside, I came a cropper when opening a new workbook and trying to activate it, so to avoid that I change this macro to:
Code: 
Sub OpenBook()
' This section notes the file path.
' It then copies the data from the canvas received Data file.
' It opens a new workbook, activates it and pastes the data.
    
[COLOR=Red]Set NewWBk = Workbooks.Add[/COLOR]
    Workbooks.Open Filename:=ThisWorkbook.Path & "\Data.csv"
    ActiveSheet.UsedRange.Copy
    [COLOR=Red]NewWBk.Activate[/COLOR]
   ' [COLOR=SeaGreen]Windows("Book4").Activate[/COLOR]
    ActiveSheet.Paste
End Sub
Back to the main topic, for the combo macro, try (tested here):
Code: 
Sub Combo()
' EXPERIMENTAL

Dim Found1 As Range, Found2 As Range, Found3 As Range, Found4 As Range, Found5 As Range, Found6 As Range, Found7 As Range
Dim lastcol As Long, delcol As Long
Dim Temp1 As String, Temp2 As String
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For delcol = lastcol To 1 Step -1
If Cells(1, delcol) = "Combo" Then Cells(1, delcol).EntireColumn.Delete
Next
Set Found1 = Rows(1).Find(what:="ProdCode", LookIn:=xlValues, lookat:=xlWhole)
Set Found2 = Rows(1).Find(what:="ClientCode", LookIn:=xlValues, lookat:=xlWhole)
Set Found3 = Rows(1).Find(what:="Type", LookIn:=xlValues, lookat:=xlWhole)
Set Found4 = Rows(1).Find(what:="SubType", LookIn:=xlValues, lookat:=xlWhole)
Set Found5 = Rows(1).Find(what:="Month", LookIn:=xlValues, lookat:=xlWhole)
Set Found6 = Rows(1).Find(what:="Week", LookIn:=xlValues, lookat:=xlWhole)
Set Found7 = Rows(1).Find(what:="Year", LookIn:=xlValues, lookat:=xlWhole)
Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Select
ActiveCell.Value = "Combo"
ActiveCell.Offset(1, 0).Select
[COLOR=Red]y = Cells(Rows.Count, Range("1:1").Find("Time_Stamp", , , xlWhole).Column).End(xlUp).Row[/COLOR]
[COLOR=Red]Set myRng = ActiveCell.Resize(y - 1)
myRng.Formula = "=" & Found1.Offset(1, 0).Address(False, False) & " & "","" & " & Found2.Offset(1, 0).Address(False, False) _
& " & "","" & " & Found3.Offset(1, 0).Address(False, False) & " & "","" & " & Found4.Offset(1, 0).Address(False, False) _
& " & "","" & " & Found5.Offset(1, 0).Address(False, False) & " & "","" & " & Found6.Offset(1, 0).Address(False, False) _
& " & "","" & " & Found7.Offset(1, 0).Address(False, False)
myRng.Value = myRng.Value[/COLOR]
End Sub
 
Upvote 0
Hey Sous!

Ok I tried it out and the first one worked, the 2nd one gave a run-time error of 1004.

Also here is another link where you can download the files:
http://dl.dropbox.com/u/550012/EXCEL-MACRO.zip

Thanks for all of your help!!!

sous2817 said:
Now with less looping!

Code: 
Sub foo()
 
Dim Found1 As Long, Found2 As Long, Found3 As Long, Found4 As Long, Found5 As Long, Found6 As Long, Found7 As Long
Dim lastcol As Long, delcol As Long, lastrow As Long, i As Long
Dim Temp1 As String, Temp2 As String
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
 
With Sheet1
 
lastcol = Last(2, .Cells)
lastrow = Last(1, .Cells)
 
For delcol = lastcol To 1 Step -1
    If .Cells(1, delcol) = "Combo" Then .Cells(1, delcol).EntireColumn.Delete
Next
 
Found1 = FindColumn("ProdCode")
Found2 = FindColumn("ClientCode")
Found3 = FindColumn("Type")
Found4 = FindColumn("SubType")
Found5 = FindColumn("Month")
Found6 = FindColumn("Week")
Found7 = FindColumn("Year")
 
.Cells(1, lastcol + 1).Value = "combo"
 
.Cells(2, lastcol + 1).FormulaR1C1 = "=RC" & Found1 & "& "","" & RC" & Found2 & "& "","" & RC" & Found3 & "& "","" & RC" & Found4 & "& "","" & RC" & Found5 & "& "","" & RC" & Found6 & "& "","" & RC" & Found7
.Cells(2, lastcol + 1).AutoFill Destination:=Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1))
 
Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Calculate
Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Value = Range(.Cells(2, lastcol + 1), .Cells(lastrow, lastcol + 1)).Value
 
End With
 
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
 
End Sub

Don't forget the 2 functions I posted earlier.
Click to expand...
 
Upvote 0
Sorry, change this line:

Code: 
With Sheet1

to:

Code: 
With ActiveSheet

Was doing a bit of testing and forgot to change it back.

See if that change makes it work.
 
Upvote 0
Outstanding, glad I could help! Best of luck with the rest of your project and feel free to post back if you need anything else.
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Adapt VBA code where "Find" is equal to a MID function (etc)
Replies
6
Views
269
GTS
G
J
  • Solved
VBA Code Error Unable to get the Match property of the WorksheetFunction class
Replies
8
Views
293
Jiraya_00
J
T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
306
tixarah
T
D
  • Solved
VBA copying entire rows and over writing destination formatting
Replies
3
Views
356
Alex Blakenburg
A
R
  • Question Question
[VBA] - Need to Hide one column and need sum of columns
Replies
0
Views
192
rsolanki
R

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,636
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top