Sub Generate_CSV() Dim mypath As String Dim lacode As String Dim myFile As String Dim local_office As String 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False End With ActiveWorkbook.Save Call UnprotectWorksheets mypath = Application.ActiveWorkbook.path mydate = Now mydate = Replace(mydate, "/", "-") mydate = Replace(mydate, ":", "") '============================================== 'AW Patch added 13-Nov0-2015 'Regenerate Stock UPRNs just in case Call Update_stock_UPRNs 'Ensure UPRNs are correct on the Enter Data Here worksheet Call Populate_MissingData 'End of Patch '============================================== Call Generate_HL1CompletedCheck 'Check to ensure that HL1 Application References have been provided 'Count of Offer Dates not blank 'Count of non-blank HL1 APPREFs all_hl1_complete = Worksheets("ENTER DATA HERE").Range("T1").Value If all_hl1_complete <> 0 Then Worksheets("ENTER DATA HERE").Activate MsgBox ("Error: One or more HL1 Application References have not been completed! Please fix all blank HL1 Application references and then try again. No data has been sent.") GoTo exitallcode End If 'Make sure all the HL3 Appref's have been generated Call Generate_HL3APPREF 'Make sure we have the most upto date version of the data Call Generate_Stage 'Now Generate the HL3 Data from the Input Data Call Generate_HL3Format Application.CutCopyMode = False Worksheets("Generate HL3").Activate lacode = Worksheets("Generate HL3").Range("A4").Value local_office = Worksheets("ENTER DATA HERE").Range("B2").Value Worksheets("Generate HL3").Range("A4:T5000").Select Selection.Copy Workbooks.Add Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Range("D:D,P:P,R:R").Select Range("R1").Activate Selection.NumberFormat = "dd/mm/yyyy" 'Make sure no leading zeros drop Columns("B:C").Select Selection.NumberFormat = "@" Columns("D:D").EntireColumn.AutoFit Columns("P:P").EntireColumn.AutoFit Columns("R:R").EntireColumn.AutoFit 'Sort the columns so the blanks are at the bottom Range("A1:T1").Select Range(Selection, Selection.End(xlDown)).Select ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add key:=Range( _ "A1:A5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:T5000") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'find the first non-blank row Set sh = ActiveSheet RowCount = 1 For Each rw In sh.Rows If Cells(RowCount, 1).Value = "" Then Exit For RowCount = RowCount + 1 Next rw RowCount = RowCount - 1 sh.Range("A1:T" & RowCount).Select Selection.Copy Worksheets.Add Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False Columns("B:C").Select Selection.NumberFormat = "@" 'Create a Data Recovery Folder of all old extracts On Error Resume Next MkDir mypath & "\Data Recovery" On Error GoTo 0 Dim myrange As Range Set myrange = sh.Range("A1:T" & RowCount) 'Now save the file myFile = "HL3 " & lacode & " - " & local_office & " " & mydate & ".csv" 'Call CreateTextFile(mypath & "\" & myFile, myrange) ActiveWorkbook.SaveAs Filename:= _ mypath & "\Data Recovery\" & myFile _ , FileFormat:=xlCSV, CreateBackup:=False ActiveWorkbook.Close Application.DisplayAlerts = True Worksheets("ENTER DATA HERE").Activate 'Generate the Stock File Call exportstock Worksheets("ENTER DATA HERE").Activate lacode = Range("B1").Value local_office = Range("B2").Value mystockFile = "STOCK " & lacode & " - " & local_office & ".csv" stockfile = mypath & "\Stock\" & mystockFile 'Call CreateTextFile(mypath & "\" & myFile, myrange) 'Send the worksheet to the Scottish Government ' Dim OutApp As Object 'Dim OutMail As Object 'Dim emailaddress As String 'Dim myfilefull As String myfilefull = mypath & "\Data Recovery\" & myFile send_HL3_to_SG = mypath & "\Send these files to SG\" & myFile send_STOCK_to_SG = mypath & "\Send these files to SG\" & mystockFile '====================================================================== 'COPY FILES TO Send these files to SG 'NAC Patch as use Lotus Notes rather than outlook Dim fso As Object Set fso = VBA.CreateObject("Scripting.FileSystemObject") 'empty the folder first Kill mypath & "\Send these files to SG\*.*" Call fso.CopyFile(myfilefull, send_HL3_to_SG) Call fso.CopyFile(stockfile, send_STOCK_to_SG) 'Set OutApp = CreateObject("Outlook.Application") 'Set OutMail = OutApp.CreateItem(0) 'emailaddress = Worksheets("SEND DATA").Range("B3").Value 'On Error Resume Next ' Change the mail address and subject in the macro before you run it. 'With OutMail ' .To = emailaddress ' .CC = "" ' .BCC = "" ' .Subject = "HL3 Extract sent from Standalone System" ' .Body = "Check that the LACODE matches the sendee's email address" ' .Attachments.Add myfilefull ' .Attachments.Add stockfile ' You can add other files by uncommenting the following line. '.Attachments.Add ("C:\test.txt") ' In place of the following statement, you can use ".Display" to ' display the mail. .send ' .Display ' End With ' On Error GoTo 0 ' Set OutMail = Nothing ' Set OutApp = Nothing '====================================================================== 'ARCHIVE THE DATA WHICH HAS BEEN CLOSED OFF ' This macro archives the closed data to leave just the live cases ' Call ArchiveData exitallcode: 'Restore ScreenUpdating, Calculation and EnableEvents Call UnprotectWorksheets With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic .DisplayAlerts = True End With 'Now shell the file in a new window Shell "explorer.exe" & " " & mypath & "\Send these files to SG\", vbNormalFocus End Sub Sub ArchiveData() Worksheets("ENTER DATA HERE").Activate 'Select all available data Range("A9").Select Set sh = ActiveSheet max_rows = 9 For Each rw In sh.Rows If Cells(max_rows, 1).Value = "" Then Exit For max_rows = max_rows + 1 Next rw 'Get the last row of data max_rows = max_rows - 1 Range("A9:P" & max_rows).Select ActiveWorkbook.Worksheets("ENTER DATA HERE").Sort.SortFields.Clear ActiveWorkbook.Worksheets("ENTER DATA HERE").Sort.SortFields.Add key:=Range( _ "P9:P" & max_rows), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ xlSortNormal With ActiveWorkbook.Worksheets("ENTER DATA HERE").Sort .SetRange Range("A8:P" & max_rows) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'Find the first row where the case is at stage 2 Range("P9").Select Set sh = ActiveSheet stage2_start = 1 For Each rw In sh.Rows If Cells(stage2_start, 16).Value = 2 Then Exit For stage2_start = stage2_start + 1 Next rw If stage2_start > 20000 Then 'No data to archive Sheets("ENTER DATA HERE").Activate GoTo exitallcode End If Range("A" & stage2_start & ":O" & max_rows).Select Selection.Copy Sheets("ARCHIVE").Select 'Find the first empty row on the Archive sheet Range("A1").Select Set sh = ActiveSheet max_rows_archive = 1 For Each rw In sh.Rows If Cells(max_rows_archive, 1).Value = "" Then Exit For max_rows_archive = max_rows_archive + 1 Next rw 'Get the last row of data and make sure it's one more max_rows_archive = max_rows_archive 'Paste in the archived data Range("A" & max_rows_archive).Select Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _ xlNone, SkipBlanks:=False, Transpose:=False 'Clear the archived data from the data entry sheet Sheets("ENTER DATA HERE").Activate Sheets("ENTER DATA HERE").Range("A" & stage2_start & ":P" & max_rows).Select Selection.ClearContents With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Range("A" & stage2_start).Select exitallcode: End Sub Sub Generate_HL3Format() 'How many rows do I need to Generate? Worksheets("ENTER DATA HERE").Activate 'Select the heading Row Range("A8").Select 'Select all available data Range("A9").Select Set sh = ActiveSheet max_rows = 9 For Each rw In sh.Rows If Cells(max_rows, 1).Value = "" Then Exit For max_rows = max_rows + 1 Next rw 'Get the last row of data max_rows = max_rows - 6 'Make sure all yes and no are in proper case Call Correct_capitals Worksheets("Generate HL3").Activate 'Clear the existing data Range("A4:T5000").Value = "" 'Make sure all formating has been removed from Range("P:P,R:R").Select Selection.NumberFormat = "@" Range("A4:A" & max_rows).Formula = "=VLOOKUP('ENTER DATA HERE'!$B$1,'Lookup Lists'!$A$2:$B$33,2,FALSE)" For Each Cell In Range("B4:B" & max_rows) Cell.Value = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 1).Text Next Range("C4:C" & max_rows).FormulaR1C1 = "=IF('ENTER DATA HERE'!R[5]C1<>"""",'ENTER DATA HERE'!R[5]C15,"""")" Range("D4:D" & max_rows).FormulaR1C1 = "=IF(ISNUMBER('ENTER DATA HERE'!R[5]C5),'ENTER DATA HERE'!R[5]C5,"""")" Range("E4:N" & max_rows).FormulaR1C1 = "=IF(AND('ENTER DATA HERE'!R[5]C7='Generate HL3'!R1C,'ENTER DATA HERE'!R[5]C9=""Offered and Accepted""),2,IF(AND('ENTER DATA HERE'!R[5]C7='Generate HL3'!R1C,'ENTER DATA HERE'!R[5]C9=""Offered and Refused""),1,0))" Range("E4:N" & max_rows).Value = Range("E4:N" & max_rows).Value Range("E4:M" & max_rows).Select 'Find and replaceN/A where no accommodation was offered Selection.Replace What:="#N/A", Replacement:="0", LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("N4:N" & max_rows).Select Selection.Replace What:="#N/A", Replacement:="1", LookAt:=xlWhole, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False 'Fox the Take Up Cells For Each Cell In Range("O4:O" & max_rows) Children = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 4).Value offertype = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 6).Value accepted = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 9).Value takeup = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 10).Value entrydate = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 11).Value Unsuitable = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 12).Value exitdate = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 13).Value breach = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 14).Value UPRN = Worksheets("ENTER DATA HERE").Cells(Cell.Row + 5, 8).Value If offertype <> "No temporary accommodation offered" And accepted = "Offered and Accepted" And takeup = "Yes" Then 'Take Up Cell.Value = 1 'EntryDate 'Cell.Offset(0, 1) = Format(entrydate, "dd/mm/yyyy") mydate = entrydate If Month(mydate) < 10 Then my_month = "0" & Month(mydate) Else my_month = Month(mydate) End If If Day(mydate) < 10 Then my_day = "0" & Day(mydate) Else my_day = Day(mydate) End If Cell.Offset(0, 1) = my_day & "/" & my_month & "/" & Year(mydate) 'Unsuitable Accommodation If Children = "Yes" And Unsuitable = "Yes" Then Cell.Offset(0, 2) = 1 ElseIf Children = "yes" And Unsuitable = "no" Then Cell.Offset(0, 2) = 0 Else Cell.Offset(0, 2) = "" End If 'ExitDate If exitdate <> "" Then 'Cell.Offset(0, 3) = Format(exitdate, "dd/mm/yyyy") mydate = exitdate If Month(mydate) < 10 Then my_month = "0" & Month(mydate) Else my_month = Month(mydate) End If If Day(mydate) < 10 Then my_day = "0" & Day(mydate) Else my_day = Day(mydate) End If Cell.Offset(0, 3) = my_day & "/" & my_month & "/" & Year(mydate) Else Cell.Offset(0, 3) = "" End If 'Breach If breach = "Yes" And Unsuitable = "Yes" Then Cell.Offset(0, 4) = 1 ElseIf breach = "No" And Unsuitable = "Yes" Then Cell.Offset(0, 4) = 0 Else Cell.Offset(0, 4) = "" End If 'UPRN Cell.Offset(0, 5) = UPRN ElseIf offertype <> "No temporary accommodation offered" And accepted = "Offered and Accepted" And takeup = "No" Then Cell.Value = 0 Cell.Offset(0, 1) = "" Cell.Offset(0, 2) = "" Cell.Offset(0, 3) = "" Cell.Offset(0, 4) = "" Cell.Offset(0, 5) = UPRN Else Cell.Value = "" Cell.Offset(0, 1) = "" Cell.Offset(0, 2) = "" Cell.Offset(0, 3) = "" Cell.Offset(0, 4) = "" Cell.Offset(0, 5) = UPRN End If Next 'Clear the contents of later rows Range("A" & max_rows + 1 & ":T10000").Value = "" End Sub Sub CreateTextFile(myFile As String, rng As Range) Dim cellValue As Variant, i As Integer, j As Integer Open myFile For Output As #1 For i = 1 To rng.Rows.Count For j = 1 To rng.Columns.Count cellValue = rng.Cells(i, j).Value If j = rng.Columns.Count Then Write #1, cellValue Else Write #1, cellValue, End If Next j Next i Close #1 End Sub