VBA Wizard Needed - True / False Concatenate generated number in Specic column

L

LNG2013

Active Member
Joined
May 23, 2011
Messages
466
I use a web app to produce a survey. It gives me an output in a csv. The check box's output is True or False.

I need to create a VBA macro that looks at the specific columns, my columns change order, and if the column has a True statement it puts a specific number in Column Code1 based on the column that was true.

All of the numbers will need to be concatenated together in the column, each number is seperated by a space. If a column has a False statement, it does not put a number on Code1.

See the table below for an example layout.

ValueA1 if True = 1
ValueB1 if True = 2
ValueC1 if True = 3
ValueD1 if True = 4
ValueE1 if True = 5
ValueF1 if True = 6
ValueG1 if True = 7
False = no number in Code1 column.

<STYLE type=text/css>
table.tableizer-table {border: 1px solid #CCC; font-family: Arial, Helvetica, sans-serif; font-size: 12px;} .tableizer-table td {padding: 4px; margin: 3px; border: 1px solid #ccc;}
.tableizer-table th {background-color: #104E8B; color: #FFF; font-weight: bold;}
</STYLE>
<TABLE style="WIDTH: 713px; HEIGHT: 175px" class=tableizer-table>
<TBODY><TR class=tableizer-firstrow><TH>ValueA1</TH><TH>ValueB1</TH><TH>ValueC1</TH><TH>ValueD1</TH><TH>ValueE1</TH><TH>ValueF1</TH><TH>ValueG1</TH><TH>Code1</TH></TR><TR><TD>TRUE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>1 4 7</TD></TR><TR><TD>FALSE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>3 5 7</TD></TR><TR><TD>TRUE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>1 2 5 </TD></TR><TR><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>TRUE</TD><TD>2 6 7</TD></TR><TR><TD>FALSE</TD><TD>FALSE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>TRUE</TD><TD>FALSE</TD><TD>4 6 </TD></TR>





</TABLE>

Let me say how awesome this forum is! Everyone has been emmensely helpful in helping me with my questions! It is really appreciated!:biggrin:
 
Sort by date Sort by votes
Hey Sthrncali,

Thanks for your help unfortunately I keep getting error with some of the code, specifically that which is in red text below.

Code: 
[COLOR=red] LC = ActiveSheet.Range("XX1").End(xlToLeft).Column[/COLOR]
LR = ActiveSheet.Range("A65536").End(xlUp).Row



Sthrncali said:
I think this will get the job done.

Let me know if you run into any problems with it...

Code: 
Sub CustomConcat()
 
Dim LC As Integer, LR As Integer
Dim Identifier As String
Dim A1 As String, B1 As String, C1 As String, D1 As String, E1 As String, F1 As String, G1 As String
Dim Code1 As Integer
 
LC = ActiveSheet.Range("XX1").End(xlToLeft).Column
LR = ActiveSheet.Range("A65536").End(xlUp).Row
 
For r = 1 To 1
For c = 1 To LC
If ActiveSheet.Cells(r, c).Value = "Code1" Then
Code1 = ActiveSheet.Cells(r, c).Column
End If
Next
Next
 
For r = 2 To LR
For c = 1 To LC
If ActiveSheet.Cells(r, c).Value = "True" Then
Identifier = ActiveSheet.Cells(1, c).Value
Select Case Identifier
 Case "ValueA1"
    A1 = "1 "
 Case "ValueB1"
    B1 = "2 "
 Case "ValueC1"
    C1 = "3 "
 Case "ValueD1"
    D1 = "4 "
 Case "ValueE1"
    E1 = "5 "
 Case "ValueF1"
    F1 = "6 "
 Case "ValueG1"
    G1 = "7"
End Select
 
End If
 
Next
 
ActiveSheet.Cells(r, Code1).Value = A1 & B1 & C1 & D1 & E1 & F1 & G1
 
A1 = ""
B1 = ""
C1 = ""
D1 = ""
E1 = ""
F1 = ""
G1 = ""
 
Next
 
End Sub
Click to expand...
 
Upvote 0

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
Hey Sous I keep getting a syntax error with this part


Code: 
[COLOR=red]Function Find_Data(what As String, rng As Range, how As Long, Optional LookAt As XlLookAt = xlPart)
[/COLOR]' how = 1 returns row
' how = 2 returns column
sous2817 said:
Whoops...missed the "columns could be in any order" bit. Try this....it should be pretty quick because you're only looping through the 7 columns to check for a "True" rather than the entire sheet (where you have a lot of columns you may not be using). 10k rows took less than 2 seconds on my machine...:

Code: 
Option Explicit
Option Base 1
Sub foo2()
Dim output As Long, lc As Long, lr As Long, i As Long, t As Long, k As Long, w As Long
Dim r As Range
Dim j(7) As Long
Dim nArray() As String
Dim sNumber As String
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
 
With Sheet1
    lr = Last(1, .Cells)
    lc = Last(2, .Cells)
 
Set r = Range(.Cells(1, 1), .Cells(1, lc))
 
output = Find_Data("Code1", r, 2, xlWhole)
 
j(1) = Find_Data("ValueA1", r, 2, xlWhole)
j(2) = Find_Data("ValueB1", r, 2, xlWhole)
j(3) = Find_Data("ValueC1", r, 2, xlWhole)
j(4) = Find_Data("ValueD1", r, 2, xlWhole)
j(5) = Find_Data("ValueE1", r, 2, xlWhole)
j(6) = Find_Data("ValueF1", r, 2, xlWhole)
j(7) = Find_Data("ValueG1", r, 2, xlWhole)
 
For w = 2 To lr
    k = 0
    For i = LBound(j) To UBound(j)
        t = j(i)
        If .Cells(w, t).Value = "True" Then
            k = k + 1
            ReDim Preserve nArray(1 To k)
            nArray(k) = j(i)
        End If
    Next i
            sNumber = Join(nArray, " ")
            .Cells(w, output).Value = sNumber
            sNumber = ""
            Erase nArray
Next w
End With
 
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
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 Find_Data(what As String, rng As Range, how As Long, Optional LookAt As XlLookAt = xlPart)
' how = 1 returns row
' how = 2 returns column
 
Select Case how
 
    Case 1:
        On Error Resume Next
        Find_Data = rng.Find(what:=what, _
                        After:=rng.Cells(1), _
                        LookAt:=LookAt, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        On Error GoTo 0
 
    Case 2:
        On Error Resume Next
        Find_Data = rng.Find(what:=what, _
                        After:=rng.Cells(1), _
                        LookAt:=LookAt, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
End Select
End Function
Click to expand...
 
Upvote 0
Sorry...Forgot to change Sheet1 to ActiveSheet. See if the code below runs (I don't have issue on my side)


Code: 
Option Explicit
Option Base 1
Sub foo2()
Dim output As Long, lc As Long, lr As Long, i As Long, t As Long, k As Long, w As Long
Dim r As Range
Dim j(7) As Long
Dim nArray() As String
Dim sNumber As String
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
 
With ActiveSheet    
    lr = Last(1, .Cells)
    lc = Last(2, .Cells)
 
Set r = Range(.Cells(1, 1), .Cells(1, lc))
 
output = Find_Data("Code1", r, 2, xlWhole)
 
j(1) = Find_Data("ValueA1", r, 2, xlWhole)
j(2) = Find_Data("ValueB1", r, 2, xlWhole)
j(3) = Find_Data("ValueC1", r, 2, xlWhole)
j(4) = Find_Data("ValueD1", r, 2, xlWhole)
j(5) = Find_Data("ValueE1", r, 2, xlWhole)
j(6) = Find_Data("ValueF1", r, 2, xlWhole)
j(7) = Find_Data("ValueG1", r, 2, xlWhole)
 
For w = 2 To lr
    k = 0
    For i = LBound(j) To UBound(j)
        t = j(i)
        If .Cells(w, t).Value = "True" Then
            k = k + 1
            ReDim Preserve nArray(1 To k)
            nArray(k) = j(i)
        End If
    Next i
            sNumber = Join(nArray, " ")
            .Cells(w, output).Value = sNumber
            sNumber = ""
            Erase nArray
Next w
End With
 
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
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 Find_Data(what As String, rng As Range, how As Long, Optional LookAt As XlLookAt = xlPart)
' how = 1 returns row
' how = 2 returns column
 
Select Case how
 
    Case 1:
        On Error Resume Next
        Find_Data = rng.Find(what:=what, _
                        After:=rng.Cells(1), _
                        LookAt:=LookAt, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        On Error GoTo 0
 
    Case 2:
        On Error Resume Next
        Find_Data = rng.Find(what:=what, _
                        After:=rng.Cells(1), _
                        LookAt:=LookAt, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
End Select
End Function
 
Upvote 0
Give this macro a try...
Code: 
Sub GetCodes()
  Dim Codes As String, C As Long, R As Long, LastCol As Long, LastRow As Long, CurrentRow As Long, CodeColumns() As Long, Headers As Variant
  Const HeaderRow As Long = 1
  Const StartCol As Long = 1
  Const CodesCol As String = "N"
  Headers = Split("ValueA1,ValueB1,ValueC1,ValueD1,ValueE1,ValueF1,ValueG1", ",")
  ReDim CodeColumns(1 To UBound(Headers) + 1)
  LastCol = Cells(HeaderRow, Columns.Count).End(xlToLeft).Column
  LastRow = Cells(Rows.Count, StartCol).End(xlUp).Row
  For C = 0 To UBound(Headers)
    CodeColumns(C + 1) = Range(Cells(HeaderRow, StartCol), Cells(HeaderRow, LastCol)).Find(Headers(C), LookAt:=xlWhole, MatchCase:=False).Column
  Next
  For R = HeaderRow + 1 To LastRow
    Codes = ""
    For C = 1 To UBound(CodeColumns)
      If Cells(R, CodeColumns(C)).Value Then Codes = Codes & " " & C
    Next
    Cells(R, CodesCol).Value = Trim(Codes)
  Next
End Sub
There are four lines of code that you might need to change depending on your setup. I used your example table for the values I used...
Code: 
  Const HeaderRow As Long = 1
  Const StartCol As Long = 1
  Const CodesCol As String = "N"
  Headers = Split("ValueA1,ValueB1,ValueC1,ValueD1,ValueE1,ValueF1,ValueG1", ",")
The HeaderRow is the first row of the table where the headers are located. The StartCol is the column number for the upper left corner of the table. The CodesCol is the column where the outputted codes are to be placed in. Inside the Split function being assigned to the Headers array is a list of your headers in numerical order of their code numbers. So, ValueA1 is first in the list because its code number is 1, ValueB1 is second in the list because its code number it 2, and so on. The list is comma delimited with NO blank spaces on either side of the commas that limit the list (in other words, the text at the beginning, end and between commas are exactly the header text used in the tables).
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
VBA code clean up
Replies
9
Views
583
mumps
mumps
E
  • Question Question
Adding a custom message.
Replies
1
Views
666
Micron
M
M
  • Question Question
Isolate a number in string specified to the same number of digit without an extra number attached to it
Replies
0
Views
320
Martin1978
M
S
  • Question Question
How to extract Start and End time for a true/false event from a data sheet using vba code?
2
Replies
11
Views
866
Syed Ahmad Ali Shah
S
E
  • Question Question
Create mails with table - standard header specific row
Replies
1
Views
1K
esben
E

Forum statistics

Threads
1,224,602
Messages
6,179,843
Members
452,948
Latest member
UsmanAli786

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