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

 

[Lars1]

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

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 ?

 

[diddi]

dump the file extension.

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]

might need to do this

    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]

View attachment 33375 dump the file extension.

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

    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]

lovely. thx bye for now!

 

[Lars1]

lovely. thx bye for now!

Hi Diddi

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

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]

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

 

[diddi]

well heres a new one... bit of messing around because i dont like using ReDim Preserve for arrays

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]

well heres a new one... bit of messing around because i dont like using ReDim Preserve for arrays

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

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

 

[diddi]

have you broken it again.
whats the error