Format columns in a listbox as Currency

[Lars1]

Hi
I am quite new to VBA, and i have a problem with som formats in a listbox.
I would like column 8 and column 10 formatted as currency #.###,## kr the Danish format.

As it is now it comes out with plain numbers like 1000 and the result i am looking for is 1.000,00 kr

There are also two columns formatted as "Short Time", but this is maybe not the best way to format these two columns



Private Sub FillContacts(Optional sFilter As String = "*")
Dim i As Long, j As Long

'Clear any existing entries in the ListBox
Me.ListBox1.Clear

'Loop through all the rows and columns of the contact list
For i = LBound(maContacts, 1) To UBound(maContacts, 1)
For j = 1 To 10
'Compare the contact to the filter
If UCase(maContacts(i, j)) Like UCase("*" & sFilter & "*") Then
'Add it to the ListBox
With Me.ListBox1
.AddItem maContacts(i, 1)
.List(.ListCount - 1, 1) = maContacts(i, 2)
.List(.ListCount - 1, 2) = maContacts(i, 3)
.List(.ListCount - 1, 3) = maContacts(i, 4)
.List(.ListCount - 1, 4) = maContacts(i, 5)
.List(.ListCount - 1, 4) = Format(Time, "Short Time")
.List(.ListCount - 1, 5) = maContacts(i, 6)
.List(.ListCount - 1, 5) = Format(Time, "Short Time")
.List(.ListCount - 1, 6) = maContacts(i, 7)
.List(.ListCount - 1, 7) = maContacts(i, 8)
.List(.ListCount - 1, 8) = maContacts(i, 9)
.List(.ListCount - 1, 9) = maContacts(i, 10)
End With
'If any column matched, skip the rest of the columns
'and move to the next contact
Exit For
End If
Next j
Next i
'Select the first contact
If Me.ListBox1.ListCount > 0 Then Me.ListBox1.ListIndex = 0

 

[diddi]

i have a collection of generic (standalone) routines that are useful utilities. if you are planning on coding much, they are very useful to keep. and one of them is a sort routing fro dates. so here it is. dump it in a module and you can access it in other userforms if needed.

Sub SortDateColumnDown(myArray As Variant, ColNum As Integer)

' myArray is the 2d array to be sorted
' ColNum is the sort column (base 0)

    Dim tempi As String, tempj As String, i As Long, J As Long
    NumCols = UBound(myArray, 2)

    For i = 0 To UBound(myArray, 1) - 1
        For J = i + 1 To UBound(myArray, 1)
            tempi = DateValue(myArray(i, ColNum))
            tempj = DateValue(myArray(J, ColNum))
            If tempi < tempj Then
                For col = 0 To NumCols
                    sTemp = myArray(i, col)
                    myArray(i, col) = myArray(J, col)
                    myArray(J, col) = sTemp
                Next
            End If
        Next J
    Next i
End Sub

and i use it like this in your case:

MyTempArray=listbox1
SortDateColumnDown MyTempArray,3
ListBox1.list=MyTempArray
Erase MyTempArray

 

[diddi]

dont know if you can see the vintage... 1966. i needed some inspiration to get your problem sorted

 

[Lars1]

dont know if you can see the vintage... 1966. i needed some inspiration to get your problem sorted

I can not see it, but am a little jealous of both the bottle and your abilities for VBA

 

[diddi]

hahaha. do you want to look at anything else or are you right for now

 

[Lars1]

hahaha. do you want to look at anything else or are you right for now

Hi Diddi

I ran in to a little problem.
I would clean the "database" for data, which i am going to do regularly.
When i have an empty database i got this error:

 

[Lars1]

hahaha. do you want to look at anything else or are you right for now

AND i just discovered another problem with the date format in my sheet "database".
After adding new data to the database, It looks like the database contains different formats on the date.
If i mark the column "Date" and change the format from "short date" to "Long Date" only some of the data is changed.

 

[diddi]

what code line does it fail at.
could you link me a new copy please. i have dumped the other i think

 

[Lars1]

what code line does it fail at.
could you link me a new copy please. i have dumped the other i think

Once again i am glad you would like to help me with this

This one is with "Date error"

Transfer - Dropbox

Dropbox is a free service that lets you bring your photos, docs, and videos anywhere and share them easily. Never email yourself a file again!

www.dropbox.com

This one is with the Database error

Transfer - Dropbox

Dropbox is a free service that lets you bring your photos, docs, and videos anywhere and share them easily. Never email yourself a file again!

www.dropbox.com

 

[diddi]

try this change

Sub Setup()
    Dim cMedarbejder As Range
    Dim cLoc As Range
    Set ws = Worksheets("Medarbejdere")
  
    If Database.ListObjects("Tabel_Database").ListRows.Count > 0 Then  ' add this
        maContacts = Database.ListObjects("Tabel_Database").DataBodyRange.Value
        '    FillContacts
      
        For Each cMedarbejder In ws.Range("medarbejderIDList")
            With cboID
                .AddItem cMedarbejder.Value
                .List(.ListCount - 1, 1) = cMedarbejder.Offset(0, 1).Value
            End With
        Next cMedarbejder
    End If ' add this

    With ws
        .Cells(lRow, 1).Value = cboID.Value
        .Cells(lRow, 2).Value = cboID.List(lPart, 1)
        '.Cells(lRow, 3).Value = cboGodkendt.Value
        .Cells(lRow, 4).Value = Format(txtDate.Value, "dd mmmm yyyy")  ' this line
        .Cells(lRow, 5).Value = txtStart.Value
        .Cells(lRow, 6).Value = txtStop.Value
        .Cells(lRow, 7).Value = txtQty.Value
        .Cells(lRow, 12).Value = txtAccord.Value
        .Cells(lRow, 11).Value = txtProduct.Value
    End With

 

[Lars1]

try this change

Sub Setup()
    Dim cMedarbejder As Range
    Dim cLoc As Range
    Set ws = Worksheets("Medarbejdere")
 
    If Database.ListObjects("Tabel_Database").ListRows.Count > 0 Then  ' add this
        maContacts = Database.ListObjects("Tabel_Database").DataBodyRange.Value
        '    FillContacts
     
        For Each cMedarbejder In ws.Range("medarbejderIDList")
            With cboID
                .AddItem cMedarbejder.Value
                .List(.ListCount - 1, 1) = cMedarbejder.Offset(0, 1).Value
            End With
        Next cMedarbejder
    End If ' add this

    With ws
        .Cells(lRow, 1).Value = cboID.Value
        .Cells(lRow, 2).Value = cboID.List(lPart, 1)
        '.Cells(lRow, 3).Value = cboGodkendt.Value
        .Cells(lRow, 4).Value = Format(txtDate.Value, "dd mmm yyyy")  ' this line
        .Cells(lRow, 5).Value = txtStart.Value
        .Cells(lRow, 6).Value = txtStop.Value
        .Cells(lRow, 7).Value = txtQty.Value
        .Cells(lRow, 12).Value = txtAccord.Value
        .Cells(lRow, 11).Value = txtProduct.Value
    End With

I must do something wrong here...