Format columns in a listbox as Currency

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
97
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
97
Office Version
  1. 365
Platform
  1. Windows
oh i broke in

just an observation with your backup. you only have one backup because the next one overwrites the previous. so if someone messes it all up, and then does a backup you loose your data
not the best plan imo
1614674460704.png

Maybe i ONLY should define the path, and not the filename..

I see the problem.
Maybe the solution to this is to create a backup on the server instead.
Or du you have a better idea ?
 

Some videos you may like

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,267
Office Version
  1. 2010
Platform
  1. Windows
1614674649914.png
dump the file extension.

VBA Code:
Sub CopyWorkbook() 'kopierer kun en del af arket "database" til fil på F drevet og gemmer uden kæder

'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(Trim(TextBox2.Value) & ".xlsm").Worksheets("Database").Range("A:R").PasteSpecial Paste:=xlPasteValues
    Workbooks("AkkordData.xlsm").Close SaveChanges:=True
End Sub

i would not give the option of naming the file and i would just do a daily backup like it or not
 

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,267
Office Version
  1. 2010
Platform
  1. Windows
might need to do this
VBA Code:
    Workbooks.Open(Trim(TextBox2.Value) & ".xlsm").Worksheets("Database").Range("A:R").PasteSpecial Paste:=xlPasteValues
    Workbooks(Trim(TextBox2.Value) & ".xlsm").Close SaveChanges:=True

i will think about autobackup if you want to do that
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
97
Office Version
  1. 365
Platform
  1. Windows
View attachment 33375 dump the file extension.

VBA Code:
Sub CopyWorkbook() 'kopierer kun en del af arket "database" til fil på F drevet og gemmer uden kæder

'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(Trim(TextBox2.Value) & ".xlsm").Worksheets("Database").Range("A:R").PasteSpecial Paste:=xlPasteValues
    Workbooks("AkkordData.xlsm").Close SaveChanges:=True
End Sub

i would not give the option of naming the file and i would just do a daily backup like it or not

might need to do this
VBA Code:
    Workbooks.Open(Trim(TextBox2.Value) & ".xlsm").Worksheets("Database").Range("A:R").PasteSpecial Paste:=xlPasteValues
    Workbooks(Trim(TextBox2.Value) & ".xlsm").Close SaveChanges:=True

i will think about autobackup if you want to do that
Perfect...
Once again thank you SO much Diddi

I have learned a lot from this project and you are a very patient man :)

by the way.
Check out Poppelvej.com
Special wines from your country, but created by a Dane...
 

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,267
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

lovely. thx bye for now!
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
97
Office Version
  1. 365
Platform
  1. Windows
lovely. thx bye for now!
Hi Diddi

It looks like you "sortedDate" code only look at "Day" and not the "month" and "Year"
1614849974561.png


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)

    Dim tempi As String, tempj As String, i As Long, J As Long, NumCols As Long, Col As Long, stemp As String
'    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

Private Sub Label13_Click() 'Sorter data ud fra "date"
    With Label13
        If .ForeColor = &HC000C0 Then
            .ForeColor = &H80000012
            ListBox1.List = ActualData
        Else
            .ForeColor = &HC000C0
            ListBox1.List = SortedData
        End If
    End With
End Sub
 

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,267
Office Version
  1. 2010
Platform
  1. Windows

ADVERTISEMENT

hmmmm... i will have a think. it does not take into account the different date formats. needs a bit of a mod :)
 

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,267
Office Version
  1. 2010
Platform
  1. Windows
well heres a new one... bit of messing around because i dont like using ReDim Preserve for arrays

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
    
    ' create a temporary array and add an extra column
    ReDim NewArray(0 To UBound(myArray, 1), 0 To UBound(myArray, 2) + 1)
    NumCols = UBound(NewArray, 2)
    
    ' copy the original array and include the date serial number in new last column
    For I = 0 To UBound(NewArray, 1)
        For J = 0 To NumCols
            If J < NumCols Then
                NewArray(I, J) = myArray(I, J)
            Else
                NewArray(I, J) = CLng(DateSerial(Year(myArray(I, ColNum)), Month(myArray(I, ColNum)), Day(myArray(I, ColNum))))
            End If
        Next J
    Next I
    
    'switch the sort to the last column and then sort
    ColNum = NumCols
    For I = 0 To UBound(NewArray, 1) - 1
        For J = I + 1 To UBound(NewArray, 1)
            Tempi = NewArray(I, ColNum)
            Tempj = NewArray(J, ColNum)
            If Tempi < Tempj Then
                For Col = 0 To NumCols
                    sTemp = NewArray(I, Col)
                    NewArray(I, Col) = NewArray(J, Col)
                    NewArray(J, Col) = sTemp
                Next
            End If
        Next J
    Next I
    
    'copy the sorted temporary array contents back to the original without the extra column
    For I = 0 To UBound(NewArray, 1)
        For J = 0 To NumCols - 1
            myArray(I, J) = NewArray(I, J)
        Next J
    Next I
End Sub
 

Lars1

Board Regular
Joined
Feb 3, 2021
Messages
97
Office Version
  1. 365
Platform
  1. Windows
well heres a new one... bit of messing around because i dont like using ReDim Preserve for arrays

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
  
    ' create a temporary array and add an extra column
    ReDim NewArray(0 To UBound(myArray, 1), 0 To UBound(myArray, 2) + 1)
    NumCols = UBound(NewArray, 2)
  
    ' copy the original array and include the date serial number in new last column
    For I = 0 To UBound(NewArray, 1)
        For J = 0 To NumCols
            If J < NumCols Then
                NewArray(I, J) = myArray(I, J)
            Else
                NewArray(I, J) = CLng(DateSerial(Year(myArray(I, ColNum)), Month(myArray(I, ColNum)), Day(myArray(I, ColNum))))
            End If
        Next J
    Next I
  
    'switch the sort to the last column and then sort
    ColNum = NumCols
    For I = 0 To UBound(NewArray, 1) - 1
        For J = I + 1 To UBound(NewArray, 1)
            Tempi = NewArray(I, ColNum)
            Tempj = NewArray(J, ColNum)
            If Tempi < Tempj Then
                For Col = 0 To NumCols
                    sTemp = NewArray(I, Col)
                    NewArray(I, Col) = NewArray(J, Col)
                    NewArray(J, Col) = sTemp
                Next
            End If
        Next J
    Next I
  
    'copy the sorted temporary array contents back to the original without the extra column
    For I = 0 To UBound(NewArray, 1)
        For J = 0 To NumCols - 1
            myArray(I, J) = NewArray(I, J)
        Next J
    Next I
End Sub
1615184446448.png

Hi Diddi
I got this error message with this new code...
 

diddi

Well-known Member
Joined
May 20, 2004
Messages
3,267
Office Version
  1. 2010
Platform
  1. Windows
have you broken it again.
whats the error
 

Watch MrExcel Video

Forum statistics

Threads
1,127,316
Messages
5,623,961
Members
416,002
Latest member
Neshx

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