I have a data set out of our timetabling system (at University of Tasmania) where the weeks that a class is taught for come out in a very unhelpful mix of comma separated values, and ranges with hyphens. Like this:
Example Teaching Weeks Patterns
11,12,13-16,17-21 OR
9-17,18-27 OR
2,3,4,5,6,8-9
The attached macro was designed to look at all of these values, and go through and replace the ranges with comma separated standalone weeks.
It works nicely, but is too inefficient. I have attempted to speed it up, but the 1300+ possible combinations (and the need to check for all of them) is slowing things down. Does anyone have any thoughts looking at the attached, to see if it could be improved in terms of processor demand?
Sub ReplaceHyphens()
'
' ReplaceHyphens Macro
' Used to replace week ranges with specific week numbers
'
'
Dim strCol As String
Dim myRange As String
strCol = InputBox("Please specify the column to be adjusted.... then go and make a coffee (it can take up to 8 min to process!)")
If strCol = "" Then
MsgBox "You didn't specify a column!", vbCritical
Exit Sub
End If
myRange = strCol & ":" & strCol
For i = 1 To 1327
Worksheets("Sheet1").Range(myRange).Select
row1 = Selection.Row
maxrow = Cells(Rows.Count, 1).End(xlUp).Row
numcol = Selection.Columns.Count
col1 = Selection.Column
maxcol = col1 + numcol - 1
For r = row1 To maxrow
For c = col1 To maxcol
cellval = Cells(r, c).Value
If cellval <> "" Then
If Left(cellval, 1) <> "," Then cellval = "," & cellval & ","
Cells(r, c).Formula = cellval
End If
Next c
Next r
Selection.Replace What:=Worksheets("Ctrl+Shift+R to replace hyphens").Cells(i, 1).Value, Replacement:=Worksheets("Ctrl+Shift+R to replace hyphens").Cells(i, 2).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next i
Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Can you add the macro in a work book and some test data so we dont have to recreate?
Oh, so sorry I thought I had attached the workbook!
Here 'tis...
You could use something like this:
Sub ReplaceHyphens()
'
' ReplaceHyphens Macro
' Used to replace week ranges with specific week numbers
'
'
Dim strCol As String
strCol = InputBox("Please specify the column to be adjusted.... then go and make a coffee (it can take up to 8 min to process!)")
If strCol = "" Then
MsgBox "You didn't specify a column!", vbCritical
Exit Sub
End If
Dim DataSheet As Worksheet
Set DataSheet = Worksheets("Sheet1")
With DataSheet
maxrow = .Cells(.Rows.Count, strCol).End(xlUp).Row
Dim rng As range
Set rng = .range(.Cells(2, strCol), .Cells(maxrow, strCol))
End With
Dim dataSet
dataSet = rng.Value
For r = LBound(dataSet) To UBound(dataSet)
dataSet(r, 1) = SplitOutHyphens(dataSet(r, 1))
Next r
rng.Value = dataSet
End Sub
Function SplitOutHyphens(InputText) As String
Dim parts
parts = Split(InputText, ",")
Dim x As Long
For x = LBound(parts) To UBound(parts)
If InStr(parts(x), "-") <> 0 Then
Dim NumberRange
NumberRange = Split(parts(x), "-")
Dim lower As Long
lower = NumberRange(0)
Dim upper As Long
upper = NumberRange(1)
Dim y As Long
Dim OutputText As String
OutputText = vbNullString
For y = lower To upper
OutputText = OutputText & "," & y
Next y
parts(x) = Mid$(OutputText, 2)
End If
Next x
SplitOutHyphens = Join$(parts, ",")
End Function
Velouria, thank you that's perfect!
