• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 204
  • Last Modified:

Formating a list in Excel using VBA

Hi there,

I have a column of contract numbers in Column A that I would like to format as below:

('contract#1','contract#2','contract#3',................,'contract#x')

Where contract#x is the last contract number on the list.

The result could be in a single cell or entered in a seperate txt file... .either way is fine.

Could anyone help out with this code in VBA?

Thanks,
Mattt
0
Aleyna
Asked:
Aleyna
  • 6
  • 5
1 Solution
 
jpaulinoCommented:
Why don't you goto Data - text to columns and split by ',' ? If you need some automation you can record a macro.
0
 
Jeroen RosinkCommented:
Hello Mattt,
To get the values in one single cell like cell B1 then this macro might help you out.

Sub ColumnInCellB1()
Dim rows As Long
Dim tmp As String
RowsA = Cells(rows.Count, 1).End(xlUp).Row
tmp = ""
For i = 1 To RowsA
If tmp = "" Then
    tmp = Cells(i, 1)
Else
    tmp = tmp & vbLf & Cells(i, 1)
End If
'place content of column A in cell B1
[B1] = tmp
End Sub

regards,
Jeroen
0
 
Jeroen RosinkCommented:
to write the content of column A to a text file loacted on: C:\temp\TEXTFILE.TXT

Sub WriteToTextFile()
Dim FileNum As Integer, i As Long
RowsA = Cells(rows.Count, 1).End(xlUp).Row
tmp = ""
RowsA = Cells(rows.Count, 1).End(xlUp).Row
    If Dir("C:\temp\TEXTFILE.TXT") <> "" Then
        ' deletes the file if it exists
        Kill "C:\temp\TEXTFILE.TXT"
    End If
    FileNum = FreeFile ' next free filenumber
    Open "C:\temp\TEXTFILE.TXT" For Output As #FileNum
    ' creates the new file
    'Open "C:\FOLDERNAME\TEXTFILE.TXT" For Append As #FileNum
    ' appends the input to an existing file
    ' write to the textfile
    For i = 1 To RowsA
        Write #FileNum, Cells(i, 1)
    Next i
    Close #FileNum ' close the file
End Sub
0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
AleynaAuthor Commented:
Sorry maybe I wasn't too clear, at the moment I have this in column A (the real list is longer)

12345
45678
34567

And I need to get this list to be:

('12345','45678','34567')

So thats why I think I need a macro to complete the task.

Thanks for your quick responces.
Regards,
Matt
0
 
AleynaAuthor Commented:
Roos01,

The last code is close... but it creates a txt file like this

"123"
"345"
"456"

instead can you do it so that it does:

('123','345','456')
0
 
Jeroen RosinkCommented:
replace the lines of code:

    For i = 1 To RowsA
        Write #FileNum, Cells(i, 1)
    Next i

with

    For i = 1 To RowsA
If tmp = "" Then
    tmp = Cells(i, 1)
Else
    tmp = tmp & ", "& Cells(i, 1)
End If
    Next i

        Write #FileNum, tmp

Do you also need the single quotes and the ( and) around?

0
 
Jeroen RosinkCommented:
it would be then something like:
Sub WriteToTextFile()
Dim FileNum As Integer, i As Long
RowsA = Cells(rows.Count, 1).End(xlUp).Row
tmp = ""
RowsA = Cells(rows.Count, 1).End(xlUp).Row
    If Dir("C:\temp\TEXTFILE.TXT") <> "" Then
        ' deletes the file if it exists
        Kill "C:\temp\TEXTFILE.TXT"
    End If
    FileNum = FreeFile ' next free filenumber
    Open "C:\temp\TEXTFILE.TXT" For Output As #FileNum
    ' creates the new file
    'Open "C:\FOLDERNAME\TEXTFILE.TXT" For Append As #FileNum
    ' appends the input to an existing file
    ' write to the textfile
    For i = 1 To RowsA
        If tmp = "" Then
            tmp = "('" & Cells(i, 1)
        Else
            tmp = tmp & "','" & Cells(i, 1)
        End If
         
    Next i
    tmp = tmp & "')"
      Write #FileNum, tmp
    Close #FileNum ' close the file
End Sub
0
 
AleynaAuthor Commented:
Roos01,

we are really close... at the moment I get this:

"123, 123, 45, 125"

I need it as:

('123','123','45','125')

So basicaly the " has to change to a ' and also it has to be at the begining and end of each number
and yes the ( and ) are also need
0
 
AleynaAuthor Commented:
Roos01,

the last code gives me:

"('123','123','45','125')"

Which is great, know if I may be picky is it possible to remove the beginign and ending "  the reason is I won't be the only one using this code so I don't want other users to copy the " by mistake,,

You are a legend, thanks for your help!

Regards,
M
0
 
Jeroen RosinkCommented:
I tried to get the first and last quotes away, still as it is an string, VBA deals with it as a string. Sorry I cannot get closer to this. An option would be creating another file where it removes all quotes. The it is to hope that none places in a cell an "

Jeroen
0
 
AleynaAuthor Commented:
Jeroen,

I will just let the team know... Thanks so much for yuor help!!

This will really help a lot!
Regards,
Matt
0
 
Jeroen RosinkCommented:
Hello Matt,

here some piece of nasty code added to remove the all quotes

Sub WriteToTextFile()
Dim FileNum As Integer, i As Long
RowsA = Cells(Rows.Count, 1).End(xlUp).Row
tmp = ""
RowsA = Cells(Rows.Count, 1).End(xlUp).Row
    If Dir("C:\temp\TEXTFILE.TXT") <> "" Then
        ' deletes the file if it exists
        Kill "C:\temp\TEXTFILE.TXT"
    End If
    FileNum = FreeFile ' next free filenumber
    Open "C:\temp\TEXTFILE.TXT" For Output As #FileNum
    ' creates the new file
    'Open "C:\FOLDERNAME\TEXTFILE.TXT" For Append As #FileNum
    ' appends the input to an existing file
    ' write to the textfile
    For i = 1 To RowsA
        If tmp = "" Then
            tmp = "('" & Cells(i, 1)
        Else
            tmp = tmp & "','" & Cells(i, 1)
        End If
         
    Next i
    tmp = tmp & "')"
      Write #FileNum, tmp
    Close #FileNum ' close the file
   
    ReplaceTextInFile "C:\temp\TEXTFILE.TXT", Chr(34), ""
   
End Sub
Sub ReplaceTextInFile(SourceFile As String, _
    sText As String, rText As String)
Dim TargetFile As String, tLine As String, tString As String
Dim p As Integer, i As Long, F1 As Integer, F2 As Integer
    TargetFile = "RESULT.TMP"
    If Dir(SourceFile) = "" Then Exit Sub
    If Dir(TargetFile) <> "" Then
        On Error Resume Next
        Kill TargetFile
        On Error GoTo 0
        If Dir(TargetFile) <> "" Then
            MsgBox TargetFile & _
                " already open, close and delete / rename the file and try again.", _
                vbCritical
            Exit Sub
        End If
    End If
    F1 = FreeFile
    Open SourceFile For Input As F1
    F2 = FreeFile
    Open TargetFile For Output As F2
    i = 1 ' line counter
    Application.StatusBar = "Reading data from " & _
        TargetFile & " ..."
    While Not EOF(F1)
        If i Mod 100 = 0 Then Application.StatusBar = _
            "Reading line #" & i & " in " & _
            TargetFile & " ..."
        Line Input #F1, tLine
        If sText <> "" Then
            ReplaceTextInString tLine, sText, rText
        End If
        Print #F2, tLine
        i = i + 1
    Wend
    Application.StatusBar = "Closing files ..."
    Close F1
    Close F2
    Kill SourceFile ' delete original file
    Name TargetFile As SourceFile ' rename temporary file
    Application.StatusBar = False
End Sub

Private Sub ReplaceTextInString(SourceString As String, _
    SearchString As String, ReplaceString As String)
Dim p As Integer, NewString As String
    Do
        p = InStr(p + 1, UCase(SourceString), UCase(SearchString))
        If p > 0 Then ' replace SearchString with ReplaceString
            NewString = ""
            If p > 1 Then NewString = Mid(SourceString, 1, p - 1)
            NewString = NewString + ReplaceString
            NewString = NewString + Mid(SourceString, _
                p + Len(SearchString), Len(SourceString))
            p = p + Len(ReplaceString) - 1
            SourceString = NewString
        End If
        If p >= Len(NewString) Then p = 0
    Loop Until p = 0
End Sub

Jeroen
0

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

  • 6
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now