Learner1983
New Member
- Joined
- Apr 12, 2013
- Messages
- 5
Hi There
I am new to writing macros. I am trying to write a macro which will split the sheets (2 or 3) into different files. I have the Index file where i have gropued the sheets (A1:B23) into file names and from A32:A39 i have mentioned the files to be created.
below is untested macro and i am getting error in Do while row
Option Explicit
Public iCurrentRow, iCurrentCol
Public SupportSheet
Sub split_files()
Dim StrCurrentText As String
Dim strdir As String
Dim rng, r As Range
'Dim iCurrentRow, iCurrentCol
strdir = "C:\Macro_Files"
iCurrentRow = 32
iCurrentCol = 1
Set SupportSheet = Worksheets("Index")
SupportSheet.Cells(iCurrentRow, iCurrentCol).Select
StrCurrentText = SupportSheet.Cells(iCurrentRow, iCurrentCol)
Do While SupportSheet.Cells(StrCurrentText) <> ""
'SupportSheet.Select
SupportSheet.Range("B1").AutoFilter field:=2, Criteria1:=Cells(StrCurrentText).Value
Set rng = SupportSheet.AutoFilter.Range
Set r = SupportSheet.AutoFilter.Range
For Each r In rng
Worksheets(r).Copy
ActiveWorkbook.SaveAs Filename:=strdir + StrCurrentText + ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close
Next
iCurrentRow = iCurrentRow + 1
StrCurrentText = SupportSheet.Cells(iCurrentRow, iCurrentCol)
Loop
End Sub
Please Help
I am new to writing macros. I am trying to write a macro which will split the sheets (2 or 3) into different files. I have the Index file where i have gropued the sheets (A1:B23) into file names and from A32:A39 i have mentioned the files to be created.
below is untested macro and i am getting error in Do while row
Option Explicit
Public iCurrentRow, iCurrentCol
Public SupportSheet
Sub split_files()
Dim StrCurrentText As String
Dim strdir As String
Dim rng, r As Range
'Dim iCurrentRow, iCurrentCol
strdir = "C:\Macro_Files"
iCurrentRow = 32
iCurrentCol = 1
Set SupportSheet = Worksheets("Index")
SupportSheet.Cells(iCurrentRow, iCurrentCol).Select
StrCurrentText = SupportSheet.Cells(iCurrentRow, iCurrentCol)
Do While SupportSheet.Cells(StrCurrentText) <> ""
'SupportSheet.Select
SupportSheet.Range("B1").AutoFilter field:=2, Criteria1:=Cells(StrCurrentText).Value
Set rng = SupportSheet.AutoFilter.Range
Set r = SupportSheet.AutoFilter.Range
For Each r In rng
Worksheets(r).Copy
ActiveWorkbook.SaveAs Filename:=strdir + StrCurrentText + ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close
Next
iCurrentRow = iCurrentRow + 1
StrCurrentText = SupportSheet.Cells(iCurrentRow, iCurrentCol)
Loop
End Sub
Please Help