SAVING WORKSHEET NAMED ONLY WITH NUMBERS

jawahars
2StarLounger
Posts: 113
Joined: 09 Jan 2014, 10:06
Location: Chennai, Tamil nadu, india.

SAVING WORKSHEET NAMED ONLY WITH NUMBERS

Post by jawahars »

Hi in the below codeing i have a problem it is saving all the sheet in one work book expect the interface1 sheet.

but i need to save each tab as different workbook with the contision of the tab which is named with numbers need to be saved not the one which contain even one alphabet.

and the orginal macro file only need the INPUT tab and the STATIONPL TAB all other need to be deleted.

Kindly help me.



CODE:-

Code: Select all

Sub INTERFACE()
Dim JA As Worksheet, JA1 As Worksheet
     For Each JA In ThisWorkbook.Worksheets
        If JA.Name = "INTERFACE" Then
            Application.DisplayAlerts = False
            JA.Delete
            Application.DisplayAlerts = True
        End If
    Next JA
 For Each JA1 In ThisWorkbook.Worksheets
        If JA1.Name = "INTERFACE1" Then
            Application.DisplayAlerts = False
            JA1.Delete
            Application.DisplayAlerts = True
        End If
    Next JA1
 Dim INTERFACE As String, INTERFACE1 As String
 Worksheets("INPUT").Select
      Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("INPUT").Sort.SortFields.Clear
     ActiveWorkbook.Worksheets("INPUT").Sort.SortFields.Add Key:=Range("E2:E1047685") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("INPUT").Sort
        .SetRange Range("A1:N1047685")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("D:D").Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(0, 2), TrailingMinusNumbers:=True
Worksheets.Add After:=Worksheets("Input")
ActiveSheet.Name = "INTERFACE"
Worksheets("INPUT").Select
Range("B:B,C:C,D:D,E:E,F:F,N:N").Select
Selection.Copy
Worksheets("Interface").Select
Range("A1").PasteSpecial
    Dim wshT As Worksheet
    Dim lngRow As Long
    Set wshT = Worksheets("INTERFACE")
    lngRow = wshT.Range("D" & wshT.Rows.Count).End(xlUp).Row + 1
    wshT.Range(lngRow & ":" & wshT.Rows.Count).Rows(1).Insert
    wshT.Range("A1:F1").Copy Destination:=wshT.Range("A" & (lngRow + 1))
    Range("G1").Formula = "=left(D1,6)"
    wshT.Range("G1").Copy Destination:=wshT.Range("G2:G" & lngRow)
    wshT.Range(lngRow & ":" & wshT.Rows.Count).Copy
    Worksheets.Add After:=Worksheets("INTERFACE")
    ActiveSheet.Name = "INTERFACE1"
    Worksheets("INTERFACE1").Select
    Range("A1").PasteSpecial
    Worksheets("INTERFACE").Select
    lngRowS = wshT.Range("D" & wshT.Rows.Count).End(xlUp).Row
    wshT.Range(lngRowS & ":" & wshT.Rows.Count).Clear
    Worksheets("INTERFACE1").Select
    Range("G2").Formula = "=MID(B2,10,3)"
    Range("H2").Formula = "=A2"
    Range("I2").Formula = "=C2"
    Range("J2").Formula = "=VLOOKUP(G2,STATIONPL!$A:$B,2,0)"
    Range("K2").Formula = "=VLOOKUP(F2,INTERFACE!$F:$G,2,0)"
    Range("L2").Formula = "000000N1000000000000"
    Range("M2").Formula = "=MID(H2,8,1)"
    Dim wshTS As Worksheet
    Dim lngRowS1 As Long
    Set wshTS = Worksheets("INTERFACE1")
    lngRowS1 = wshTS.Range("A" & wshTS.Rows.Count).End(xlUp).Row
    wshTS.Range("G2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wshTS.Range("H2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wshTS.Range("I2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wshTS.Range("J2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wshTS.Range("K2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wshTS.Range("L2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wshTS.Range("M2" & lngRowS1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    Cells.Select
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Columns.AutoFit
    Columns("B:D").Select
    Selection.Delete
    Columns("C:E").Select
    Selection.Delete
    Columns("B:B").Select
    Selection.Copy
    Range("H1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:B").Select
    Selection.Delete
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Rows("1:1").Select
    Selection.Delete
    Dim wshTS1 As Worksheet
    Dim lngRowS2 As Long
    Set wshTS1 = Worksheets("INTERFACE1")
    lngRowS2 = wshTS1.Range("F" & wshTS1.Rows.Count).End(xlUp).Row
    wshTS1.Range(lngRowS2 & ":" & wshTS1.Rows.Count).Clear
    Range("A1:K1").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("INTERFACE1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("INTERFACE1").Sort.SortFields.Add Key:=Range( _
        "K1:K1047685"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("INTERFACE1").Sort
        .SetRange Range("A1:K1047685")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Formula = "Line"
    Range("B1").Formula = "Reference"
    Range("C1").Formula = "GL CODE"
    Range("D1").Formula = "Extension"
    Range("B2").Formula = "=F2"
    Range("C2").Formula = "=G2&H2"
    Range("D2").Formula = "=I2&J2"
    Dim wsfin As Worksheet
    Dim lngfin As Long
    Set wsfin = Worksheets("INTERFACE1")
    lngfin = wsfin.Range("F" & wsfin.Rows.Count).End(xlUp).Row
    wsfin.Range("B2" & lngfin).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wsfin.Range("C2" & lngfin).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    wsfin.Range("D2" & lngfin).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    lngfin = wsfin.Range("F" & wsfin.Rows.Count).End(xlUp).Row
    wsfin.Range(lngfin & ":" & wsfin.Rows.Count).Clear
    Cells.Select
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.Columns.AutoFit
     For Each JA In ThisWorkbook.Worksheets
        If JA.Name = "INTERFACE" Then
            Application.DisplayAlerts = False
            JA.Delete
            Application.DisplayAlerts = True
        End If
    Next JA
    
Application.CutCopyMode = False

    Const NameCol = "L"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim LastRow As Long
    Dim SrcRow As Long
    Dim TrgRow As Long
    Dim Location As String
    Dim MyPath As String
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Dim f As Boolean
    Application.ScreenUpdating = False
    With Range(Range("L1"), Range("L1").End(xlDown))
    End With
    Set SrcSheet = ActiveSheet
    LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
    For SrcRow = FirstRow To LastRow
        Location = SrcSheet.Cells(SrcRow, NameCol).Value
        Set TrgSheet = Nothing
        On Error Resume Next
        Set TrgSheet = Worksheets(Location)
        On Error GoTo 0
        If TrgSheet Is Nothing Then
            Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            TrgSheet.Name = Location
            SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
        End If
        TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
        SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
    Next SrcRow
    Application.DisplayAlerts = False
    f = True
    For Each TrgSheet In ThisWorkbook.Worksheets
        If TrgSheet.Name <> SrcSheet.Name Then
            TrgSheet.Select Replace:=f
            f = False
        End If
    Next TrgSheet
    ActiveWindow.SelectedSheets.Copy
    MyPath = ThisWorkbook.Path
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    ActiveWorkbook.SaveAs Filename:=MyPath & "INTERFACE_DATA.xlsx", FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
You do not have the required permissions to view the files attached to this post.
Last edited by HansV on 18 Apr 2014, 21:55, edited 1 time in total.
Reason: to add [code]...[/code] tags around code

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: SAVING WORKSHEET NAMED ONLY WITH NUMBERS

Post by HansV »

Change the last part of the macro to:

Code: Select all

    Const NameCol = "L"
    Const HeaderRow = 1
    Const FirstRow = 2
    Dim LastRow As Long
    Dim SrcRow As Long
    Dim TrgRow As Long
    Dim Location As String
    Dim MyPath As String
    Dim SrcSheet As Worksheet
    Dim TrgSheet As Worksheet
    Application.ScreenUpdating = False
    With Range(Range("L1"), Range("L1").End(xlDown))
    End With
    Set SrcSheet = ActiveSheet
    LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row
    For SrcRow = FirstRow To LastRow
        Location = SrcSheet.Cells(SrcRow, NameCol).Value
        If IsNumeric(Location) Then
            Set TrgSheet = Nothing
            On Error Resume Next
            Set TrgSheet = Worksheets(Location)
            On Error GoTo 0
            If TrgSheet Is Nothing Then
                Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
                TrgSheet.Name = Location
                SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow)
            End If
            TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1
            SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow)
        End If
    Next SrcRow
    Application.DisplayAlerts = False
    MyPath = ThisWorkbook.Path
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    Dim i As Long
    For i = ThisWorkbook.Worksheets.Count To 1 Step -1
        Set TrgSheet = ThisWorkbook.Worksheets(i)
        If IsNumeric(TrgSheet.Name) Then
            TrgSheet.Copy
            ActiveWorkbook.SaveAs Filename:=MyPath & TrgSheet.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
            TrgSheet.Delete
        End If
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
Best wishes,
Hans

jawahars
2StarLounger
Posts: 113
Joined: 09 Jan 2014, 10:06
Location: Chennai, Tamil nadu, india.

Re: SAVING WORKSHEET NAMED ONLY WITH NUMBERS

Post by jawahars »

Thanks Hans