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