Format columns in a listbox as Currency

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
154
Office Version
  1. 365
Platform
  1. Windows
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
 
I do what i can to sabotage your work :biggrin:

1615184729989.png
 
Upvote 0

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.
dropbox me the file so i have your data. what do you have to click to error it
 
Upvote 0
 
Upvote 0
got it. have you done any changes i should check
 
Upvote 0
got it. have you done any changes i should check
There is a lot of changes, but i think it´s more teh structure when it comes to back-up and updating the data when there is a new employee and a new product.
I don´t think there is any changes in the code, besides the Back-up module...

The next thing i would like to look at, is how to delete a line from the listbox...
 
Upvote 0
i think your are on the money there. it only errored once and wont do it now. can you replace/add this into the ModCopyWorkbook module and just see how it behaves

VBA Code:
Public Sub CopyWorkbook2()
    MsgBox "Klik på >OK< og vent på backup bliver færdig. Du skal ikke foretage dig noget før der kommer en ny boks op der siger >Backup færdig<  " & Now
   
'Copy range to clipboard
    Workbooks("LP_Akkord_MrExcel.xlsm").Worksheets("Database").Range("A:R").Copy

'Open workbook og indsæt værdier uden kæder
    Workbooks.Open("F:\Accord\LP_TEST\AkkordData.xlsx").Worksheets("Database").Range("A:R").PasteSpecial Paste:=xlPasteValues
    Workbooks("AkkordData.xlsx").Close SaveChanges:=True
   
    'Schedule this procedure again
    StartTimer
End Sub

Sub CopyWorkbook()
    MsgBox "Backup done"
   
    With Sheets("Database")
        Dim A, Row As Long, Col As Long, LastRow As Long
       
        Open "F:\Accord\LP_TEST\SampleBackup.txt" For Output As #1
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            For Row = 1 To LastRow
                For Col = 1 To 23
                    Print #1, .Cells(Row, Col) & Chr(9);
                Next Col
                Print #1, ""
            Next Row
        Close
    End With
   
    StartTimer
End Sub
 
Upvote 0
i think your are on the money there. it only errored once and wont do it now. can you replace/add this into the ModCopyWorkbook module and just see how it behaves

VBA Code:
Public Sub CopyWorkbook2()
    MsgBox "Klik på >OK< og vent på backup bliver færdig. Du skal ikke foretage dig noget før der kommer en ny boks op der siger >Backup færdig<  " & Now
 
'Copy range to clipboard
    Workbooks("LP_Akkord_MrExcel.xlsm").Worksheets("Database").Range("A:R").Copy

'Open workbook og indsæt værdier uden kæder
    Workbooks.Open("F:\Accord\LP_TEST\AkkordData.xlsx").Worksheets("Database").Range("A:R").PasteSpecial Paste:=xlPasteValues
    Workbooks("AkkordData.xlsx").Close SaveChanges:=True
 
    'Schedule this procedure again
    StartTimer
End Sub

Sub CopyWorkbook()
    MsgBox "Backup done"
 
    With Sheets("Database")
        Dim A, Row As Long, Col As Long, LastRow As Long
     
        Open "F:\Accord\LP_TEST\SampleBackup.txt" For Output As #1
            LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            For Row = 1 To LastRow
                For Col = 1 To 23
                    Print #1, .Cells(Row, Col) & Chr(9);
                Next Col
                Print #1, ""
            Next Row
        Close
    End With
 
    StartTimer
End Sub
Works fine.
Created a text file...

So the problem was. ?
 
Upvote 0
VBA Code:
Sub SortDateColumnDown(myArray As Variant, ColNum As Integer)

' myArray is the 2d array to be sorted
' ColNum is the sort column (base 0)
' Revision 2: updated to support dates after 1900 ONLY

    Dim Tempi As String, Tempj As String, I As Long, J As Long
    Dim NumCols As Long, Col As Long, sTemp As String
    Dim NewArray
    If UBound(myArray, 1) = 0 Then Exit Sub  ' <------   add this new line
 
Upvote 0

Forum statistics

Threads
1,212,928
Messages
6,110,734
Members
448,294
Latest member
jmjmjmjmjmjm

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