Hi gssachin,
if you think you need the column character(s) for building a range to loop this should do the trick:
VBA Code:
Sub MrE1221260_V2()
Dim rngStart As Range
Dim locationCell As Range
Dim varNewFile As Variant
Dim strColLetter As String
'....
'...
With ActiveSheet
On Error Resume Next
Set rngStart = Application.InputBox("Choose the starting cell in the sheet or enter address like 'A2'", "Start Cell", Type:=8)
If Err.Number <> 0 Then
MsgBox "No proper selection to start with", vbInformation, "Exit procedure"
GoTo end_here
End If
On Error GoTo 0
strColLetter = Left(.Cells(1, rngStart.Column).Address(0, 0), Len(.Cells(1, rngStart.Column).Address(0, 0)) - 1)
MsgBox strColLetter
varNewFile = Application.InputBox("Enter New File name", "New File", Type:=2)
If varNewFile = False Then
MsgBox "No new file name entered", vbInformation, "Exit procedure"
GoTo end_here
End If
For Each locationCell In .Range(.Cells(2, strColLetter), .Cells(.Rows.Count, strColLetter).End(xlUp))
' For Each locationCell In .Range(.Cells(2, rngStart.Column), .Cells(.Rows.Count, rngStart.Column).End(xlUp))
'
Next locationCell
End With
'...
end_here:
Err.Clear
Set rngStart = Nothing
End Sub
Ciao,
Holger
Sir,
It works the way I want but I have the following macro where I have to incorporate the above, which I m not able to do, can u guide me on this
In the below mail highlighted line I want to change, where if the user selects BA2 then "rowcount" should take as "AB" instead of "A" only)
Also, I m impressed with how you used to stop the Input box in the above macro. When I tried the same it get the error "Lable not found", Please help me on that also
Thanks in advance....
Public Sub Split_Sheet_By_Location()
Dim saveInFolder As String
Dim locations As Collection
Dim locationCell As Range, locationKey As Variant
Dim locationSheet As Worksheet
saveInFolder = InputBox("Enter the Folder Name (path i.e. C:\Users\10600740\Desktop\New folder ) where you want to save Files")
If Right(Trim(saveInFolder), 1) <> "\" Then saveInFolder = Trim(saveInFolder) & "\"
Shname = InputBox("Enter sheet Name")
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets(Shname)
'Create collection of unique locations from column A
Set locations = New Collection
On Error Resume Next
cellref = InputBox("Enter cell ref here")
newfilename = InputBox("Enter New File name")
For Each locationCell In .Range((cellref) & ":" & (Left(cellref, 1)) & .Cells(.Rows.Count, (Left(cellref, 1))).End(xlUp).Row)
locations.Add locationCell.Value, CStr(locationCell.Value)
Next
On Error GoTo 0
'Autofilter column A by each location and copy results to location sheet
For Each locationKey In locations
Set locationSheet = Get_Sheet(ThisWorkbook, CStr(locationKey))
.UsedRange.AutoFilter Field:=Range(cellref).Column, Operator:=xlFilterValues, Criteria1:="=" & locationKey 'Field:=1 means column A
.UsedRange.Copy locationSheet.Range("A1")
ActiveSheet.UsedRange.EntireColumn.AutoFit
Application.DisplayAlerts = False 'suppress warning if .xlsx file already exists - file is replaced
locationSheet.Copy
'ActiveSheet.UsedRange.EntireColumn.AutoFit
ActiveWorkbook.SaveAs saveInFolder & newfilename & "_" & locationKey & ".xlsx"
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Next
'Remove autofilter
.UsedRange.AutoFilter
.Activate
End With
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Private Function Get_Sheet(wb As Workbook, sheetName As String) As Worksheet
Set Get_Sheet = Nothing
With wb
On Error Resume Next
Set Get_Sheet = .Worksheets(sheetName)
On Error GoTo 0
If Get_Sheet Is Nothing Then
Set Get_Sheet = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
Get_Sheet.Name = sheetName
Else
Get_Sheet.Cells.Clear
End If
End With
End Function
