Option Explicit
Dim NeedleArr() As Variant, ColorArr() As Variant, ccc As Integer, cc As Integer, LastNeedle As Integer
Sub Embroider()
Dim LastRow As Integer, Rcnt As Integer, Cnt10 As Integer, Cnt11 As Integer, Cnt As Integer
Dim ArCnt As Integer, Cnter As Integer, Cnt2 As Integer, Total As Integer
'# of needles in Sheet1 G2
'# of needle changed in Sheet1 G3
'Input Color change number in sheet1 A3 to whatever, color number B3 to whatever, color name in C3 to whatever
'Output color positions sheet1 D3 to whatever, replacement positions in E3 to whatever
'output needle pattern sheet1 K2 to whatever
'output separate colours, names and needle changes required sheet1 A to D below input
'**remove comments to output ColorArr below needle pattern
'output adapts to changes in input
'remove previous data
Call CleanUp
'ccc = 12 'output column for ColorArr(not needed unless ColorArr displayed)
With Sheets("Sheet1")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
'bubble sort colours
Rcnt = LastRow + 2
For Cnt10 = 3 To LastRow
For Cnt11 = 3 To (Cnt10 - 1)
If Sheets("Sheet1").Range("B" & Cnt11).Value = Sheets("Sheet1").Range("B" & Cnt10).Value Then ' more than one entry
GoTo bart
End If
Next Cnt11
Rcnt = Rcnt + 1
Sheets("Sheet1").Range("A" & Rcnt).Value = Rcnt - LastRow - 2
Sheets("Sheet1").Range("B" & Rcnt).Value = Sheets("Sheet1").Range("B" & Cnt10).Value
Sheets("Sheet1").Range("C" & Rcnt).Value = Sheets("Sheet1").Range("C" & Cnt10).Value
bart:
Next Cnt10
Sheets("Sheet1").Range("C" & Rcnt + 1).Value = "Total"
'put colours in array
ReDim ColorArr(Sheets("Sheet1").Range("A" & Rcnt).Value, 3)
' ColorArr(Separate colours, 0) = colour number
' ColorArr(Separate colours, 1) = colour name
' ColorArr(Separate colours, 2) = colour changes
ArCnt = 0
For Cnt = (LastRow + 3) To Rcnt
ColorArr(ArCnt, 0) = Sheets("Sheet1").Range("B" & Cnt).Value
ColorArr(ArCnt, 1) = Sheets("Sheet1").Range("C" & Cnt).Value
ArCnt = ArCnt + 1
Next Cnt
For Cnt2 = 3 To LastRow
For Cnt = LBound(ColorArr) To UBound(ColorArr) - 1
If Sheets("Sheet1").Range("B" & Cnt2).Value = ColorArr(Cnt, 0) Then
ColorArr(Cnt, 2) = ColorArr(Cnt, 2) + 1
End If
Next Cnt
Next Cnt2
' output colour changes
For Cnt = LBound(ColorArr) To UBound(ColorArr) - 1
Sheets("Sheet1").Range("D" & (LastRow + 3 + Cnt)).Value = ColorArr(Cnt, 2)
Total = Total + ColorArr(Cnt, 2)
Next Cnt
Sheets("Sheet1").Range("D" & (LastRow + 3 + Cnt)).Value = Total
'set up needle array
ReDim NeedleArr(Sheets("Sheet1").Range("G" & 2).Value)
cc = 11 'output column for needle change display
'loop through pattern
For Cnter = 3 To LastRow
'call function to load/output color positions
Sheets("Sheet1").Range("D" & Cnter).Value = LoadNeedle(Cnter)
If Sheets("Sheet1").Range("D" & Cnter).Value = 0 Then
Sheets("Sheet1").Range("D" & Cnter).Value = vbNullString
' call function to load/output replacement positions
Sheets("Sheet1").Range("E" & Cnter).Value = ChangeNeedle(Cnter)
Sheets("Sheet1").Cells(1, cc).Value = "CHANGE " & cc - 11
'output needle set up after needle change
For Cnt = LBound(NeedleArr) To UBound(NeedleArr) - 1
Sheets("Sheet1").Cells(Cnt + 2, cc).Value = NeedleArr(Cnt)
Next Cnt
cc = cc + 1
End If
Next Cnter
End Sub
Function FindNeedle() As Integer
'change needle to needle no longer needed
'get needle not in colorarr
Dim Cnt As Integer, Cnt2 As Integer, Cnt3 As Integer, Tint As Integer, Max As Integer
For Cnt = LBound(NeedleArr) To UBound(NeedleArr) - 1
For Cnt2 = LBound(ColorArr) To UBound(ColorArr) - 1
If ColorArr(Cnt2, 0) = NeedleArr(Cnt) Then
Exit For
End If
'get max needle separartion
Tint = Abs(LastNeedle - Cnt)
If Tint <> LastNeedle Then
For Cnt3 = LBound(ColorArr) To UBound(ColorArr) - 1
If ColorArr(Cnt3, 0) = NeedleArr(Tint) Then
GoTo Below
End If
Next Cnt3
If Tint > Max Then
Max = Tint
End If
End If
Below:
Next Cnt2
Next Cnt
FindNeedle = Max
End Function
Function LoadNeedle(Rcnt As Integer) As Integer
Dim TempArr() As Variant, Cnt3 As Integer, Cnt4 As Integer, Cnt5 As Integer
Dim i As Integer, Cnt2 As Integer, Cnt As Integer, Flag As Boolean
For Cnt3 = LBound(NeedleArr) To UBound(NeedleArr) - 1
'load all needles to start
If NeedleArr(Cnt3) = vbNullString Then
Flag = False
For Cnt4 = LBound(NeedleArr) To UBound(NeedleArr) - 1
If NeedleArr(Cnt4) = Sheets("Sheet1").Range("B" & Rcnt).Value Then
Flag = True
Exit For
End If
Next Cnt4
If Not Flag Then
LoadNeedle = Cnt3 + 1
LastNeedle = Cnt3
NeedleArr(Cnt3) = Sheets("Sheet1").Range("B" & Rcnt).Value
For Cnt5 = LBound(ColorArr) To UBound(ColorArr) - 1
If NeedleArr(Cnt3) = ColorArr(Cnt5, 0) Then
ColorArr(Cnt5, 2) = ColorArr(Cnt5, 2) - 1
If ColorArr(Cnt5, 2) = 0 Then
Call RemoveItem(Cnt5)
End If
Exit For
End If
Next Cnt5
'display starting needles
If NeedleArr(UBound(NeedleArr) - 1) <> vbNullString Then
Sheets("Sheet1").Cells(1, cc).Value = "Start"
For Cnt = LBound(NeedleArr) To UBound(NeedleArr) - 1
Sheets("Sheet1").Cells(Cnt + 2, cc).Value = NeedleArr(Cnt)
Next Cnt
cc = cc + 1
End If
Exit Function
End If
End If
Next Cnt3
'load existing needles
For Cnt = LBound(ColorArr) To UBound(ColorArr) - 1
If Sheets("Sheet1").Range("B" & Rcnt).Value = ColorArr(Cnt, 0) Then
For Cnt2 = LBound(NeedleArr) To UBound(NeedleArr) - 1
If NeedleArr(Cnt2) = ColorArr(Cnt, 0) Then
ColorArr(Cnt, 2) = ColorArr(Cnt, 2) - 1
If ColorArr(Cnt, 2) = 0 Then
Call RemoveItem(Cnt)
End If
NeedleArr(Cnt2) = Sheets("Sheet1").Range("B" & Rcnt).Value
LoadNeedle = Cnt2 + 1
Exit Function
End If
Next Cnt2
End If
Next Cnt
End Function
Function ChangeNeedle(Rcnt As Integer) As Integer
Dim TempArr() As Variant, Max As Integer, Nnum As Integer, Cnt As Integer
Dim Cnt3 As Integer, Cnt4 As Integer, i As Integer, Tint As Integer
'find colour number
For Cnt = LBound(ColorArr) To UBound(ColorArr) - 1
If ColorArr(Cnt, 0) = Sheets("Sheet1").Range("B" & Rcnt).Value Then
ColorArr(Cnt, 2) = ColorArr(Cnt, 2) - 1
Nnum = FindNeedle
'all needles in use have remaining stitches
If Nnum = 0 And ColorArr(Cnt, 2) > 1 Then
For Cnt3 = LBound(NeedleArr) To UBound(NeedleArr) - 1
For Cnt4 = LBound(ColorArr) To UBound(ColorArr) - 1
If NeedleArr(Cnt3) = ColorArr(Cnt4, 0) Then
'get largest remaining
If Cnt3 <> LastNeedle Then
If ColorArr(Cnt4, 2) > Max Then
Max = ColorArr(Cnt4, 2)
Tint = Cnt3
End If
End If
End If
Next Cnt4
Next Cnt3
'output needle change/load array
ChangeNeedle = Tint + 1
NeedleArr(Tint) = Sheets("Sheet1").Range("B" & Rcnt).Value
LastNeedle = Tint
Exit For
Else
'change needle to needle no longer needed
'output needle change/load array
ChangeNeedle = Nnum + 1
NeedleArr(Nnum) = Sheets("Sheet1").Range("B" & Rcnt).Value
LastNeedle = Nnum
Exit For
End If
End If
Next Cnt
'remove colur from array if no longer needed
If ColorArr(Cnt, 2) = 0 Then
Call RemoveItem(Cnt)
End If
'Remove comments to display ColorArr
'Tint = Sheets("Sheet1").Range("G" & 2).Value
'For Cnt3 = LBound(ColorArr) To UBound(ColorArr) - 1
'Sheets("Sheet1").Cells(Cnt3 + Tint + 3, ccc).Value = ColorArr(Cnt3, 0)
'Next Cnt3
'ccc = ccc + 1
End Function
Function RemoveItem(Rcnt As Integer)
Dim i As Integer
'remove colour from ColorArr
ReDim TempArr(UBound(ColorArr) - 1, 3)
For i = LBound(TempArr) To Rcnt - 1
TempArr(i, 0) = ColorArr(i, 0)
TempArr(i, 1) = ColorArr(i, 1)
TempArr(i, 2) = ColorArr(i, 2)
Next i
For i = Rcnt To UBound(TempArr) - 1
TempArr(i, 0) = ColorArr(i + 1, 0)
TempArr(i, 1) = ColorArr(i + 1, 1)
TempArr(i, 2) = ColorArr(i + 1, 2)
Next i
ColorArr = TempArr
End Function
Sub CleanUp()
'Remove previous data
Dim LastRow As Integer, LastCol As Integer, Tint As Integer
With Sheets("Sheet1")
LastRow = .Range("L" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, "K"), .Cells(LastRow, LastCol)).ClearContents
Tint = Sheets("Sheet1").Range("G" & 3).Value
.Range(.Cells(3, "D"), .Cells(Tint + 2, "E")).ClearContents
LastRow = .Range("C" & .Rows.Count).End(xlUp).Row
.Range(.Cells(Tint + 4, "A"), .Cells(LastRow, "D")).ClearContents
End With
End Sub