VBA Code transform numbers in specific columns into other numbers

[LNG2013]

I need some VBA code that will look at only specific columns, eg: ValueA11, ValueB11, ValueC11, etc... and transform its data from a single number into a number sequence.

I have about 50 columns I need to do this for, and there are other columns that have similar data that I don't want affected by this.

Eg. the first value in the column ValueA11 = 7, I want the value to be changed into 1 2 3 4 5 6 7. The second value is 4, so it should translate to 1 2 3 4. This sequencing would not go higher then 7. More examples below:


<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: 278px; HEIGHT: 234px" class=tableizer-table>
<TBODY><TR class=tableizer-firstrow><TH>ValueA11</TH><TH>ValueA11</TH></TR><TR><TD>7</TD><TD>1 2 3 4 5 6 7</TD></TR><TR><TD>4</TD><TD>1 2 3 4</TD></TR><TR><TD>2</TD><TD>1 2</TD></TR><TR><TD>1</TD><TD>1</TD></TR><TR><TD>3</TD><TD>1 2 3</TD></TR><TR><TD>6</TD><TD>1 2 3 4 5 6</TD></TR><TR><TD>5</TD><TD>1 2 3 4 5</TD></TR>


</TABLE>

 

[jasmith4]

Here's a function to convert a number greater than 0 to the string you want. Not that the result will be text, so its value will be zero if you try to do any math on it. I'm not sure how you're designating columns and which ones to convert this way.

Public Function RavelNumber$(Number&)
    Dim I&
 
    RavelNumber$ = ""
    If Number& < 1 Then Exit Sub
 
    For I& = 1 To Number&
        If Len(RavelNumber$) > 0 Then RavelNumber$ = RavelNumber$ & Space$(1)
        RavelNumber$ = RavelNumber$ & I&
    Next
 
End Function

 

[Jonmo1]

Try

=LEFT("123456789",A1)

 

[jasmith4]

Much better! To get the spaces too:

=LEFT("1 2 3 4 5 6 7 8 9", A1*2-1)

 

[LNG2013]

How can I use this in VBA isn't this excel formula code? I need to apply it to specific columns by title.

Much better! To get the spaces too:

=LEFT("1 2 3 4 5 6 7 8 9", A1*2-1)

 

[jasmith4]

I'm assuming that your column headers begin at A1 and are in consecutive cells in row 1 -- no intervening blanks. I'm also assuming that the data begin at A2, B2, etc., and have no blanks until the bottom of the data. Here's the whole package, which will operate on columns with headers ValueA11 and ValueC11:

Public Sub DoIt()
    Call RavelColumns("ValueA11,ValueC11")
End Sub
 
Public Sub RavelColumns(HdrsToRavel$)
    Dim I&, ColHdr As Range, ColCell As Range, ColsToRavel As Variant
 
    ColsToRavel = Split(HdrsToRavel$, ",")
 
    ' Assume headers start in A1 and are contiguous
    For Each ColHdr In Range(Range("A1"), Range("A1").End(xlToRight))
 
        ' See if this header is among the desired ones
        For I& = 0 To UBound(ColsToRavel)
        If ColHdr.Text = ColsToRavel(I&) Then
 
            ' Assume data begin right below the header and are contiguous
            For Each ColCell In Range(ColHdr.Offset(1, 0), ColHdr.End(xlDown))
                If IsNumeric(ColCell.Value) Then ColCell.Value = "'" & RavelNumber$(ColCell.Value)
            Next
 
        End If
        Next
    Next
End Sub
 
Public Function RavelNumber$(Number&)
    Dim I&
 
    RavelNumber$ = ""
    If Number& < 1 Then Exit Function
 
    For I& = 1 To Number&
        If Len(RavelNumber$) > 0 Then RavelNumber$ = RavelNumber$ & Space$(1)
        RavelNumber$ = RavelNumber$ & I&
    Next
 
End Function

 

[LNG2013]

Hey Jasmith!

That worked, it takes a little while to complete, about 2-3 minutes, but it does the trick!

Any ideas on how I might speed it up a bit?

Update: there is a bad side effect, where by this code adds a bunch of commas to my csv ( it uses fields that are empty)... this makes the csv into about an 8-9mb file, it is usually 2-3k. Any idea on how to add limiters to only fields that have data in them.

I'm assuming that your column headers begin at A1 and are in consecutive cells in row 1 -- no intervening blanks. I'm also assuming that the data begin at A2, B2, etc., and have no blanks until the bottom of the data. Here's the whole package, which will operate on columns with headers ValueA11 and ValueC11:

Public Sub DoIt()
    Call RavelColumns("ValueA11,ValueC11")
End Sub
 
Public Sub RavelColumns(HdrsToRavel$)
    Dim I&, ColHdr As Range, ColCell As Range, ColsToRavel As Variant
 
    ColsToRavel = Split(HdrsToRavel$, ",")
 
    ' Assume headers start in A1 and are contiguous
    For Each ColHdr In Range(Range("A1"), Range("A1").End(xlToRight))
 
        ' See if this header is among the desired ones
        For I& = 0 To UBound(ColsToRavel)
        If ColHdr.Text = ColsToRavel(I&) Then
 
            ' Assume data begin right below the header and are contiguous
            For Each ColCell In Range(ColHdr.Offset(1, 0), ColHdr.End(xlDown))
                If IsNumeric(ColCell.Value) Then ColCell.Value = "'" & RavelNumber$(ColCell.Value)
            Next
 
        End If
        Next
    Next
End Sub
 
Public Function RavelNumber$(Number&)
    Dim I&
 
    RavelNumber$ = ""
    If Number& < 1 Then Exit Function
 
    For I& = 1 To Number&
        If Len(RavelNumber$) > 0 Then RavelNumber$ = RavelNumber$ & Space$(1)
        RavelNumber$ = RavelNumber$ & I&
    Next
 
End Function

 

[jasmith4]

See if this works any better. I removed the initial apostrophe from the converted values among other improvements:

Option Explicit
Public Sub DoIt()
    Call RavelColumns("ValueA11,ValueC11")
End Sub
 
Public Sub RavelColumns(HdrsToRavel$)
    Dim I&, ColHdrs As Range, Hdr As Range, Hdr1 As Range, ColCell As Range, ColsToRavel As Variant
 
    ColsToRavel = Split(HdrsToRavel$, ",")
 
    For I& = 0 To UBound(ColsToRavel)
 
        Set Hdr1 = Nothing
        Set Hdr = Rows(1).Find(ColsToRavel(I&), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        Do While Not Hdr Is Nothing
 
            ' Mark the first find
            If Hdr1 Is Nothing Then Set Hdr1 = Hdr
 
            ' Assume data begin right below the header and are contiguous
            For Each ColCell In Range(Hdr.Offset(1, 0), Hdr.End(xlDown))
                If IsNumeric(ColCell.Value) Then ColCell.Value = RavelNumber$(ColCell.Value)
            Next
 
            ' Continue until wrapped back to first find
            Set Hdr = Rows(1).FindNext(Hdr)
            If Hdr.Address = Hdr1.Address Then Exit Do
 
        Loop
 
    Next
End Sub
 
Public Function RavelNumber$(Number&)
    If Number& >= 1 And Number& <= 7 Then RavelNumber$ = Left("1 2 3 4 5 6 7", 2 * Number& - 1)
End Function

 

[LNG2013]

Hey Jamith!
Thanks for your help, unfortunately still got the same result, I can send you the file if you PM me your email address.

See if this works any better. I removed the initial apostrophe from the converted values among other improvements:

Option Explicit
Public Sub DoIt()
    Call RavelColumns("ValueA11,ValueC11")
End Sub
 
Public Sub RavelColumns(HdrsToRavel$)
    Dim I&, ColHdrs As Range, Hdr As Range, Hdr1 As Range, ColCell As Range, ColsToRavel As Variant
 
    ColsToRavel = Split(HdrsToRavel$, ",")
 
    For I& = 0 To UBound(ColsToRavel)
 
        Set Hdr1 = Nothing
        Set Hdr = Rows(1).Find(ColsToRavel(I&), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
        Do While Not Hdr Is Nothing
 
            ' Mark the first find
            If Hdr1 Is Nothing Then Set Hdr1 = Hdr
 
            ' Assume data begin right below the header and are contiguous
            For Each ColCell In Range(Hdr.Offset(1, 0), Hdr.End(xlDown))
                If IsNumeric(ColCell.Value) Then ColCell.Value = RavelNumber$(ColCell.Value)
            Next
 
            ' Continue until wrapped back to first find
            Set Hdr = Rows(1).FindNext(Hdr)
            If Hdr.Address = Hdr1.Address Then Exit Do
 
        Loop
 
    Next
End Sub
 
Public Function RavelNumber$(Number&)
    If Number& >= 1 And Number& <= 7 Then RavelNumber$ = Left("1 2 3 4 5 6 7", 2 * Number& - 1)
End Function

 

[jasmith4]

OK, I sent it. Can you give me an idea of the CSV's dimensions? That is, when you open it manually and do Ctrl-End, where do you end up?