Question : Rewrite the code for workbook title creation.

Hi Experts,

I would like to request Experts help to rewrite the attached script. Currently I’m using this script for naming the workbook. Now I would to add the Cell A3 value from Sheets("Source"). The data in Cell A3 is always in this format “Date : 22 August 2010 Sunday”. Hope Experts could help to revise this code.

ws2.Name = "Reconcile" & Format(ws.Range("G2").Value, "dd-mm-yyyy")

Answer : Rewrite the code for workbook title creation.

If "source" is in wb, then please change as below.

ws2.Name = Left("Reconcile " & Replace(wb.Worksheets("Source").Range("A3").Text, ":", "."), 30)

Otherwise it assumed "Source" is in ActiveWorkbook

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:



Sub Export()

    Dim wb As Workbook, wb2 As Workbook
    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    'Dim dt As String
   
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Reconcile")
   
    Set wb2 = Workbooks.Add
    Set ws2 = wb2.Worksheets("Sheet1")
    
    'ws2.Name = "Reconcile" & Format(ws.Range("G2").Value, "dd-mm-yyyy")

    ws2.Name = Left("Reconcile " & Replace(wb.Worksheets("Source").Range("A3").Text, ":", "."), 30)
    ws.Columns("A:F").Copy Destination:=ws2.Columns("A:F")
    
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .Orientation = xlLandscape
        '.Zoom = False ' Better included just in case!
        .Zoom = 40 ' Better included just in case!
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    Columns("A:F").EntireColumn.AutoFit

    Application.DisplayAlerts = False
   
    For Each ws1 In wb2.Worksheets
        If ws1.Name <> ws2.Name Then ws1.Delete
    Next ws1
       
    'Make sure Listing folder exists
    'dt = "TDC_" & ws.Range("B2").Value & ".xls"
    dt = "\\04\FileServices\Document\DBD\Reports\Reconcile_" & Format(ws.Range("G2"), "dd-mm") & ".xls"

    Application.DisplayAlerts = True
       
    wb2.SaveAs dt
        
End Sub