Code to add new lines creating wrong formatting

[dpaton05]

I have a button to add new lines to my table. The table has a date field in column A that is formatted to Australian date format. When I click the add new lines button, the new lines revert to US format for any dates that are entered in the new rows in column A. How can I force new, added rows to be Australian date formatting in column A?

Here is my add lines code.

Sub Addlines()
    Application.EnableEvents = False
    'ActiveSheet.Unprotect Password:="npssadmin"
        Dim ws As Worksheet, x As Long, tbl As ListObject, n As Long
       On Error GoTo cancelled:
       n = InputBox("How many lines would you like to add ?")
        Set ws = ActiveSheet
        Set tbl = ws.ListObjects("npss_quote")
        'add 5 rows
        For x = 1 To n
            'add a row at the end of the table
            tbl.ListRows.Add
            ActiveSheet.ListObjects("npss_quote").DataBodyRange.Columns(13).Value = 1 - 0.1 * ActiveSheet.chkIncrease.Value
        Next x
    tbl.Range.Cells(tbl.ListRows.Count - n + 2, 1).Select
    'ActiveSheet.Protect Password:="npssadmin"
    Application.EnableEvents = True
cancelled:
    Exit Sub
End Sub

Thanks for the help guys.

 

[Michael M]

Use

Range("A:A").NumberFormat = "dd/mm/yyyy"

 

[dpaton05]

Thanks for that Michael,

I had Cells(, 1).NumberFormat = "dd/mm/yyyy" as it didn't work. I just wasn't sure about the first bit of the code.

Thanks again.

 

[Michael M]

You could also use

tbl.DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"

 

[dpaton05]

Now I need to do the same thing to the tblCosting in Costing_tool but I couldn't work out where to put the code. I need column A of tblCosting to be in australian date format. Here is my code to send the lines from the quoting tool to tblCosting.

Sub cmdSend()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim desWS As Worksheet, srcWS As Worksheet
        Set srcWS = ThisWorkbook.Sheets("NPSS_quote_sheet")
        Set desWS = ThisWorkbook.Sheets("Costing_tool")
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, x As Long, header As Range
        lastRow1 = srcWS.Range("B" & srcWS.Rows.Count).End(xlUp).Row
        lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    With srcWS.Range("A:A,B:B,H:H")
        If lastRow2 < 5 Then
            lastRow2 = 5
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                If .Range("A" & .Rows.Count).End(xlUp).Row > 5 Then
                    desWS.ListObjects.Item("tblCosting").ListRows.Add
                    [B][COLOR=#ff0000]desWS.ListObjects("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"[/COLOR][/B]
                End If
                .Range("D" & lastRow2 & ":D" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 & ":F" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 & ":G" & .Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row) = srcWS.Range("B6")
            End With
        Else
            lastRow2 = desWS.Range("A:A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
            desWS.ListObjects.Item("tblCosting").ListRows.Add
            For i = 1 To .Areas.Count
                x = .Areas(i).Column
                Set header = desWS.Rows(4).Find(.Areas(i).Cells(10), LookIn:=xlValues, lookat:=xlWhole)
                If Not header Is Nothing Then
                    srcWS.Range(srcWS.Cells(11, x), srcWS.Cells(lastRow1, x)).Copy
                    desWS.Cells(lastRow2 + 1, header.Column).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next i
            With desWS
                .Range("D" & lastRow2 + 1 & ":D" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("G7")
                .Range("F" & lastRow2 + 1 & ":F" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B7")
                .Range("G" & lastRow2 + 1 & ":G" & .Range("A" & .Rows.Count).End(xlUp).Row) = srcWS.Range("B6")
            End With
        End If
    End With
    desWS.ListObjects("tblCosting").Sort.SortFields.Clear
    desWS.ListObjects("tblCosting").Sort.SortFields. _
        Add Key:=desWS.Cells(, 1), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With desWS.ListObjects("tblCosting").Sort
        .header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Call AddName
    
    With Application
        .CutCopyMode = False
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Dim oLst As ListObject
        Dim lr As Long, rng As Range
        lr = desWS.Cells(Rows.Count, "A").End(xlUp).Row
        For i = lr To 4 Step -1
            Set rng = desWS.Cells(i, 1)
            If WorksheetFunction.CountBlank(rng) = 1 Then
                desWS.Rows(i).Delete
            End If
        Next i
End Sub

I tried to add a line of code but it didn't work. Could you tell me what I did wrong please?

 

[Michael M]

shouldn't it be....untested.don't have Excel at the moment

desWS.ListObjects.[color=red]Item[/color]("tblCosting").DataBodyRange.Columns(1).NumberFormat = "dd/mm/yyyy"

and why are you using desWS at the beginning of each line when you have "With desWS"...3 lines previously ?...you just need to prefece the lines with a period.

 

[dpaton05]

Thanks Michael.