slatefamily
asked on
VBA Macro Excel_ Like String
How do I use a like term if my string my vary but always starts Profile: ConditionString = "Profile: Physician Profile-Surgery"
I have several of these, but it would be for Surgery, Medicine, etc.
Sub CopyOnString()
Dim ConditionString As String, MasterSheetName, NewSheetName
Dim LastRow As Integer, ii, FindCount, StartRange, EndRange
MasterSheetName = "Profile Export"
Worksheets(MasterSheetName ).Activate
FindCount = 0
StartRange = 0
EndRange = 0
NewSheetName = MasterSheetName
ConditionString = "Profile: Physician Profile-Surgery"
LastRow = Worksheets(MasterSheetName ).UsedRang e.Rows.Cou nt
For ii = 1 To LastRow
If Worksheets(MasterSheetName ).Cells(ii , 1) = ConditionString Or ii = LastRow Then
If FindCount > 0 Then ' not first find
EndRange = ii - 1
Worksheets.Add , Worksheets(NewSheetName)
DoEvents
NewSheetName = Split(Worksheets(MasterShe etName).Ce lls(StartR ange + 1, 1).Value, ":", 2)(1)
ActiveSheet.Name = NewSheetName
DoEvents
Worksheets(MasterSheetName ).Range(LT rim(CStr(S tartRange) ) & ":" & LTrim(CStr(EndRange))).Cop y _
Destination:=Worksheets(Ne wSheetName ).Range("1 :1")
Worksheets(NewSheetName).C olumns("A: I").AutoFi t
End If
FindCount = FindCount + 1
StartRange = ii
EndRange = 0
End If
Next
End Sub
I have several of these, but it would be for Surgery, Medicine, etc.
Sub CopyOnString()
Dim ConditionString As String, MasterSheetName, NewSheetName
Dim LastRow As Integer, ii, FindCount, StartRange, EndRange
MasterSheetName = "Profile Export"
Worksheets(MasterSheetName
FindCount = 0
StartRange = 0
EndRange = 0
NewSheetName = MasterSheetName
ConditionString = "Profile: Physician Profile-Surgery"
LastRow = Worksheets(MasterSheetName
For ii = 1 To LastRow
If Worksheets(MasterSheetName
If FindCount > 0 Then ' not first find
EndRange = ii - 1
Worksheets.Add , Worksheets(NewSheetName)
DoEvents
NewSheetName = Split(Worksheets(MasterShe
ActiveSheet.Name = NewSheetName
DoEvents
Worksheets(MasterSheetName
Destination:=Worksheets(Ne
Worksheets(NewSheetName).C
End If
FindCount = FindCount + 1
StartRange = ii
EndRange = 0
End If
Next
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.