Format columns in a listbox as Currency

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
100
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
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
100
Office Version
  1. 365
Platform
  1. Windows
ok. thats not too hard to do. its on for next time i am free
Hi Master Diddi :)

I have forgot another small issue...
When i select the first employee from the list, ALL registrations are shown in the listbox.
When i select another employee, it looks right and only this employees registration are shown.
It would be nice if only the choosen employees registrations are shown.

And regarding the delete issue.
Don´t use any time on it unless you really want to. it is only a nice thing to have...
It´s more important that i get the back-up to an excel file to work.

 

Some videos you may like

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,280
Office Version
  1. 2010
Platform
  1. Windows
employee 1 issue. i will have something to eat and come back for the backup :)

VBA Code:
Private Sub FillContacts(Optional sFilter As String = "*")
    Dim I As Long, J As Long
    
    'Clear any existing entries in the ListBox
    ListBox1.Clear
   
    'Loop through all the rows and columns of the Database
    If Database.ListObjects("Tabel_Database").ListRows.Count > 0 Then
        For I = LBound(maContacts, 1) To UBound(maContacts, 1)
            'Compare the contact to the filter
            If UCase(maContacts(I, 1)) = sFilter Then
                'Add it to the ListBox
                With ListBox1
                    If ButtonApprovedFilter Then
                        If Trim(maContacts(I, 3)) = "" Then
                            .AddItem maContacts(I, 1)
                            .List(.ListCount - 1, 1) = maContacts(I, 2) 'Navn
                            .List(.ListCount - 1, 2) = maContacts(I, 3) ' godkendt af
                            .List(.ListCount - 1, 3) = Format(maContacts(I, 4), "dd-mmm-yyyy") 'Dato
                            .List(.ListCount - 1, 4) = Format(maContacts(I, 5), "hh:mm") & "  -  " & Format(maContacts(I, 6), "hh:mm") ' start
                            '.List(.ListCount - 1, 5) = Format(maContacts(i, 6), "hh:mm") ' ****
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 7) = maContacts(I, 8) 'Vare
                            .List(.ListCount - 1, 8) = maContacts(I, 9) 'Løn
                             If maContacts(I, 9) <> "" Then .List(.ListCount - 1, 8) = FormatCurrency(maContacts(I, 9))
                            .List(.ListCount - 1, 9) = maContacts(I, 10) ' Timeløn/akkord
                            .List(.ListCount - 1, 5) = maContacts(I, 16) 'Index
                        End If
                    ElseIf ButtonTodayFilter Then ' Hvis filter Show Today er valgt
                        If maContacts(I, 4) = Date Then
                            .AddItem maContacts(I, 1)
                            .List(.ListCount - 1, 1) = maContacts(I, 2) 'Navn
                            .List(.ListCount - 1, 2) = maContacts(I, 3) ' godkendt af
                            .List(.ListCount - 1, 3) = Format(maContacts(I, 4), "dd-mmm-yyyy") 'Dato
                            .List(.ListCount - 1, 4) = Format(maContacts(I, 5), "hh:mm") & "  -  " & Format(maContacts(I, 6), "hh:mm") ' start
                            '.List(.ListCount - 1, 5) = Format(maContacts(i, 6), "hh:mm") ' ****
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 7) = maContacts(I, 8) 'Vare
                            '.List(.ListCount - 1, 8) = maContacts(I, 9) 'Løn
                             'If maContacts(I, 9) <> "" Then .List(.ListCount - 1, 8) = FormatCurrency(maContacts(I, 9))
                            '.List(.ListCount - 1, 9) = maContacts(I, 10) ' Timeløn/akkord
                            .List(.ListCount - 1, 5) = maContacts(I, 16) 'Index
                        End If
                    ElseIf ButtonNoFilter Then ' hvis filter Show all er valgt
                            .AddItem maContacts(I, 1)
                            .List(.ListCount - 1, 1) = maContacts(I, 2) 'Navn
                            .List(.ListCount - 1, 2) = maContacts(I, 3) ' godkendt af
                            .List(.ListCount - 1, 3) = Format(maContacts(I, 4), "dd-mmm-yyyy") 'Dato
                            .List(.ListCount - 1, 4) = Format(maContacts(I, 5), "hh:mm") & "  -  " & Format(maContacts(I, 6), "hh:mm") ' start
                            '.List(.ListCount - 1, 5) = Format(maContacts(i, 6), "hh:mm") ' ****
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 7) = maContacts(I, 8) 'Vare
                            .List(.ListCount - 1, 8) = maContacts(I, 9) 'Løn
                             If maContacts(I, 9) <> "" Then .List(.ListCount - 1, 8) = FormatCurrency(maContacts(I, 9))
                            .List(.ListCount - 1, 9) = maContacts(I, 10) ' Timeløn/akkord
                            .List(.ListCount - 1, 5) = maContacts(I, 16) 'Index
                    End If
                End With
            End If
        Next I
    End If
    ActualData = ListBox1.List
    SortedData = ListBox1.List
    SortDateColumnDown SortedData, 3
End Sub
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
100
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

employee 1 issue. i will have something to eat and come back for the backup :)

VBA Code:
Private Sub FillContacts(Optional sFilter As String = "*")
    Dim I As Long, J As Long
   
    'Clear any existing entries in the ListBox
    ListBox1.Clear
  
    'Loop through all the rows and columns of the Database
    If Database.ListObjects("Tabel_Database").ListRows.Count > 0 Then
        For I = LBound(maContacts, 1) To UBound(maContacts, 1)
            'Compare the contact to the filter
            If UCase(maContacts(I, 1)) = sFilter Then
                'Add it to the ListBox
                With ListBox1
                    If ButtonApprovedFilter Then
                        If Trim(maContacts(I, 3)) = "" Then
                            .AddItem maContacts(I, 1)
                            .List(.ListCount - 1, 1) = maContacts(I, 2) 'Navn
                            .List(.ListCount - 1, 2) = maContacts(I, 3) ' godkendt af
                            .List(.ListCount - 1, 3) = Format(maContacts(I, 4), "dd-mmm-yyyy") 'Dato
                            .List(.ListCount - 1, 4) = Format(maContacts(I, 5), "hh:mm") & "  -  " & Format(maContacts(I, 6), "hh:mm") ' start
                            '.List(.ListCount - 1, 5) = Format(maContacts(i, 6), "hh:mm") ' ****
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 7) = maContacts(I, 8) 'Vare
                            .List(.ListCount - 1, 8) = maContacts(I, 9) 'Løn
                             If maContacts(I, 9) <> "" Then .List(.ListCount - 1, 8) = FormatCurrency(maContacts(I, 9))
                            .List(.ListCount - 1, 9) = maContacts(I, 10) ' Timeløn/akkord
                            .List(.ListCount - 1, 5) = maContacts(I, 16) 'Index
                        End If
                    ElseIf ButtonTodayFilter Then ' Hvis filter Show Today er valgt
                        If maContacts(I, 4) = Date Then
                            .AddItem maContacts(I, 1)
                            .List(.ListCount - 1, 1) = maContacts(I, 2) 'Navn
                            .List(.ListCount - 1, 2) = maContacts(I, 3) ' godkendt af
                            .List(.ListCount - 1, 3) = Format(maContacts(I, 4), "dd-mmm-yyyy") 'Dato
                            .List(.ListCount - 1, 4) = Format(maContacts(I, 5), "hh:mm") & "  -  " & Format(maContacts(I, 6), "hh:mm") ' start
                            '.List(.ListCount - 1, 5) = Format(maContacts(i, 6), "hh:mm") ' ****
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 7) = maContacts(I, 8) 'Vare
                            '.List(.ListCount - 1, 8) = maContacts(I, 9) 'Løn
                             'If maContacts(I, 9) <> "" Then .List(.ListCount - 1, 8) = FormatCurrency(maContacts(I, 9))
                            '.List(.ListCount - 1, 9) = maContacts(I, 10) ' Timeløn/akkord
                            .List(.ListCount - 1, 5) = maContacts(I, 16) 'Index
                        End If
                    ElseIf ButtonNoFilter Then ' hvis filter Show all er valgt
                            .AddItem maContacts(I, 1)
                            .List(.ListCount - 1, 1) = maContacts(I, 2) 'Navn
                            .List(.ListCount - 1, 2) = maContacts(I, 3) ' godkendt af
                            .List(.ListCount - 1, 3) = Format(maContacts(I, 4), "dd-mmm-yyyy") 'Dato
                            .List(.ListCount - 1, 4) = Format(maContacts(I, 5), "hh:mm") & "  -  " & Format(maContacts(I, 6), "hh:mm") ' start
                            '.List(.ListCount - 1, 5) = Format(maContacts(i, 6), "hh:mm") ' ****
                            .List(.ListCount - 1, 6) = maContacts(I, 7) 'Antal
                            .List(.ListCount - 1, 7) = maContacts(I, 8) 'Vare
                            .List(.ListCount - 1, 8) = maContacts(I, 9) 'Løn
                             If maContacts(I, 9) <> "" Then .List(.ListCount - 1, 8) = FormatCurrency(maContacts(I, 9))
                            .List(.ListCount - 1, 9) = maContacts(I, 10) ' Timeløn/akkord
                            .List(.ListCount - 1, 5) = maContacts(I, 16) 'Index
                    End If
                End With
            End If
        Next I
    End If
    ActualData = ListBox1.List
    SortedData = ListBox1.List
    SortDateColumnDown SortedData, 3
End Sub
THANKS, and Bon Appetit
 

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,280
Office Version
  1. 2010
Platform
  1. Windows
version 3 for this one :)

VBA Code:
Sub CopyWorkbook()
    MsgBox "Backup er i gang. Klik på >OK< og vent..."
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        Sheets("Database").Copy
        .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="F:\Accord\LP_TEST\Tabeller\Temp.pdf", Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
        ActiveWorkbook.SaveAs "F:\Accord\LP_TEST\Tabeller\AkkordRegistrering.xlsx"
        ActiveWorkbook.Close
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
    Sheets("Indtastning").Select
End Sub
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
100
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

version 3 for this one :)

VBA Code:
Sub CopyWorkbook()
    MsgBox "Backup er i gang. Klik på >OK< og vent..."
  
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        Sheets("Database").Copy
        .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="F:\Accord\LP_TEST\Tabeller\Temp.pdf", Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
        ActiveWorkbook.SaveAs "F:\Accord\LP_TEST\Tabeller\AkkordRegistrering.xlsx"
        ActiveWorkbook.Close
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
  
    Sheets("Indtastning").Select
End Sub
Error message:
Can't copy this sheet

1615280441895.png


Got it...

VBA Code:
Sub CopyWorkbook()
    MsgBox "Backup er i gang. Klik på >OK< og vent..."
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        ActiveWorkbook.Sheets("Database").Visible = True
        Sheets("Database").Copy
        .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="F:\Accord\LP_TEST\Tabeller\Temp.pdf", Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
        ActiveWorkbook.SaveAs "F:\Accord\LP_TEST\Tabeller\AkkordRegistrering.xlsx"
        ActiveWorkbook.Close
        .DisplayAlerts = True
        .ScreenUpdating = True
        ActiveWorkbook.Sheets("Database").Visible = False
    End With
    
    Sheets("Indtastning").Select
    StartTimer
End Sub
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
100
Office Version
  1. 365
Platform
  1. Windows
Error message:
Can't copy this sheet

View attachment 33861

Got it...

VBA Code:
Sub CopyWorkbook()
    MsgBox "Backup er i gang. Klik på >OK< og vent..."
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        ActiveWorkbook.Sheets("Database").Visible = True
        Sheets("Database").Copy
        .ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="F:\Accord\LP_TEST\Tabeller\Temp.pdf", Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
        ActiveWorkbook.SaveAs "F:\Accord\LP_TEST\Tabeller\AkkordRegistrering.xlsx"
        ActiveWorkbook.Close
        .DisplayAlerts = True
        .ScreenUpdating = True
        ActiveWorkbook.Sheets("Database").Visible = False
    End With
   
    Sheets("Indtastning").Select
    StartTimer
End Sub
But the nice thing with the old code - before "sorted date column" was that i don't overwrite the existing file, but simply overwriting the data in a specific range.
This means that i could use the same sheet/workbook for calculations, filters etc.
Is it possible to do the same...

Old code:
VBA Code:
Public Sub CopyWorkbook_OLD()
    MsgBox "Backup er i gang. Klik på >OK< og vent..." & Now
    
'Copy range to clipboard
    Workbooks("Akkord_registrering.xlsm").Worksheets("Database").Range("A:R").Copy

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

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,280
Office Version
  1. 2010
Platform
  1. Windows
the problem is coming from the paste into an open workbook. i will see what other options might work
 

Watch MrExcel Video

Forum statistics

Threads
1,128,017
Messages
5,628,155
Members
416,296
Latest member
smartua

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
Top