VBA Code has stopped working correctly - formatting issue?

[kidwispa]

Hi All,

I have been running some code that people on here helped me loads with for about a month without any issues, now all of a sudden today it has decided to stop working correctly...

To give a bit of background I receive a file from one of my colleagues every day that needs to be sorted and formatted, then the relevant information for each specific agent is saved into a new worksheet in a specific directory. When I run the code (using Ctrl+q as a shortcut), before creating the worksheets it brings up a compatability error (as I'm creating the new worksheets in .xls as my colleagues are still on xl2003), then asks me if I would like to recalculate all formulas, then the files are created correctly.

Today however was different - after pressing Ctrl+q, the compatability error message box flashed up straight away, then when I clicked ok it continued to pop up for every single file that was being created (where it only popped up once before), then when my colleagues tried to open the files, they found that the date format had changed in the date columns from DD/MM/YYYY to 40779, and when they tried to change it they had an error message saying too many formats???

I've looked at the file I've received today to see if it differs in any way from the one from yesterday and can't see any obvious differences, plus I've also tried rerunning the file from yesterday and it comes up with the same problems as seen with the file from today...

Does anyone have any idea what this could be?

As always thanks for any help you can give!

 

[kidwispa]

Can anyone help???

 

[John Davis]

Can anyone help???

If you post your code I think you'll receive some useful responses.

 

[kidwispa]

If you post your code I think you'll receive some useful responses.

Here is the code:

First part (Ctrl + q macro)

Sub DataSort()
'
' DataSort Macro
'
' Keyboard Shortcut: Ctrl+q
'
Application.ScreenUpdating = False
    Rows("1:3").Select
    Selection.Delete Shift:=xlUp
 
    Run "ColumnRemove"
    Run "DataFormat"
    Run "DeleteURows"
    Run "Save_Agent_Data"
 
 
 Application.ScreenUpdating = True
 
 
End Sub

Private Sub ColumnRemove()
Dim LR As Long
Application.ScreenUpdating = False
 
    For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Range("B" & LR).Value = "" Then
            Rows(LR).EntireRow.Delete
        End If
    Next LR
Application.ScreenUpdating = True
End Sub

Sub DataFormat()
'
' DataFormat Macro
'
'
Dim LR As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
 
    Cells.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "Region"
    Range("L2").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(RC[-1],Lookup!R1C1:R19C3,3,0),""-"")"
    Range("L2").AutoFill Destination:=Range("L2:L" & LR)
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=Today()"
    Range("A2").AutoFill Destination:=Range("A2:A" & LR)
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Date"
    Columns("A").EntireColumn.AutoFit
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("DataSort").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("DataSort").Sort.SortFields.Add Key:=Range( _
        "L2:L226"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("DataSort").Sort.SortFields.Add Key:=Range( _
        "K2:K226"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("DataSort").Sort
        .SetRange Range("A1:L226")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
  Application.ScreenUpdating = True
 
End Sub

Sub DeleteURows()
Dim Lastrow As Long
Application.ScreenUpdating = False
Lastrow = Range("L" & Rows.Count).End(xlUp).Row
For i = Lastrow To 1 Step -1
If Cells(i, 12) = "-" Then Rows(i & ":" & i).EntireRow.Delete
Next i
Application.ScreenUpdating = True
End Sub

Sub Save_Agent_Data()
 
    Dim wsSource As Worksheet, Lastrow As Long
    Dim Agents As Range, Agent As Range
    Dim wbDest As Workbook
    Dim SavePath As String, AgentFilename As String
    Dim counter As Long
 
    Application.ScreenUpdating = False
 
    Set wsSource = Sheets("DataSort")
    With wsSource
        Lastrow = .Range("K" & Rows.Count).End(xlUp).Row
        .Range("K1:K" & Lastrow).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set Agents = .Range("K2:K" & Lastrow).SpecialCells(xlCellTypeVisible)
        If .FilterMode Then .ShowAllData
        .Copy
    End With
    Set wbDest = ActiveWorkbook
    wbDest.Sheets(1).UsedRange.ClearContents
 
    SavePath = "G:\Craig Ward\Lates\" & Format(Date, "dd.mm.yy") & "\"
    If Dir(SavePath, vbDirectory) = vbNullString Then MkDir SavePath
 
    For Each Agent In Agents
        wsSource.Range("K:K").AutoFilter Field:=1, Criteria1:=Agent.Value
        wsSource.UsedRange.SpecialCells(xlCellTypeVisible).Copy _
            Destination:=wbDest.Sheets(1).Range("A1")
            Range("M1").Select
            ActiveCell.FormulaR1C1 = "Comments"
            AgentFilename = Agent.Value & Format(Date, " ddmmyy") & ".xls"
            On Error Resume Next
                wbDest.SaveAs SavePath & AgentFilename, FileFormat:=56
                    '51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
                    '52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
            On Error GoTo 0
            If wbDest.Name = AgentFilename Then counter = counter + 1
            wbDest.Sheets(1).UsedRange.ClearContents
    Next Agent
 
    wbDest.Close SaveChanges:=False
    wsSource.AutoFilterMode = False
    Application.ScreenUpdating = True
 
    MsgBox counter & " files saved to " & SavePath, vbInformation, "Save Agent Data"
 
End Sub

Any help would be MASSIVELY appreciated!!!

 

[kidwispa]

To give a bit more info - I've just opened up one of the sheets and looked at the compatibility report and it shows the following:

"This workbook contains more unique cell formats than are supported by the selected file format. Some cell formats will not be saved"

Can anyone tell me why this has just started happening?