Do While Loop for SKU numbers - excel

I am trying to automate my SKU numbers. I have 3 columns. The first column has 28, the second has 6 and finally the third has 58.
I want the SKU to have a Trend like so 0{(###)col1}{(##)col2}{(##)col3}0
My Code looks like this
Sub SKU()
Dim x As Long
x = 1
i = 1
j = 1
k = 1
Do While Cells(i, 1) <> ""
Do While Cells(j, 2) <> ""
Do While Cells(k, 3) <> ""
Cells(x, 4).Value = Format(0, "0") & Format(i, "000") & _
Format(j, "00") & Format(k, "00") & Format(0, "0")
k = k + 1
x = x + 1
Loop
j = j + 1
Loop
i = i + 1
Loop
End Sub

No need to use the Do Loop. Find the last row and then use a For loop.
Is this what you are trying?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 1 To lRow
If .Cells(i, 1) <> "" And .Cells(i, 2) <> "" And .Cells(i, 3) <> "" Then
'0{(###)col1}{(##)col2}{(##)col3}0
.Cells(i, 4).Value = "'0" & _
Format(.Cells(i, 1), "000") & _
Format(.Cells(i, 2), "00") & _
Format(.Cells(i, 3), "00") & _
"0"
End If
Next i
End With
End Sub
Output for 28,6,58 is 002806580

As i mentioned in the comment to the question, remove first and second do-while loop then replace:
Cells(x, 4).Value = Format(0, "0") & Format(i, "000") & _
Format(j, "00") & Format(k, "00") & Format(0, "0")
with:
Cells(k, 4) = "'" & Format(Cells(k, 1), "000") & _
Format(Cells(k, 2), "00") & Format(Cells(k, 3), "00")
Result: 0280658
In case you want to add leading and ending zeros:
Cells(k, 4) = "'0" & Format(Cells(k, 1), "000") & _
Format(Cells(k, 2), "00") & Format(Cells(k, 3), "00") & "0"
Result: 002806580

Related

VBA Excel - Add same value to columns in different sheet

Just want to ask if how can I shorten the codes below? The codes work fine, but I just want to know if there is a way to shorten it since I'll be using the codes in N-Q1 sheet in other quarter sheets (N-Q1, N-Q2, N-Q3, N-Q4, JK-Q1, etc.). Note that, the quarter sheets have the same structure or column (column 16) to be updated, while the STUDENTS_INFO sheet is in column 20.
STUDENTS INFO sheets:
Set ws = ActiveWorkbook.Worksheets("STUDENTS_INFO")
lastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
For r = 9 To lastRow
If ws.Cells(r, 3) = CStr(ThisWorkbook.Sheets("HOME").Range("K11").value) Then
If ws.Cells(r, 20) = "0" Or ws.Cells(r, 20) = "" Then
ws.Cells(r, 20) = "1"
Debug.Print "STUDENTS: " & ws.Cells(r, 3) & " Verified!"
Else
Debug.Print "STUDENTS: " & ws.Cells(r, 3) & " Already Verified!"
End If
End If
Next r
N-Q1 code: Quarter Sheets (N-Q1, N-Q2, N-Q3, N-Q4, JK-Q1, etc.)
grd = ThisWorkbook.Sheets("HOME").Range("K16").value
qrt = CStr(ThisWorkbook.Sheets("HOME").Range("K17").value)
If grd = "Nursery" Then
ws_output = "N" + "-" + qrt
ElseIf grd = "Junior Kinder" Then
ws_output = "JK" + "-" + qrt
ElseIf grd = "Senior Kinder" Then
ws_output = "SK" + "-" + qrt
End If
Set ws = ActiveWorkbook.Worksheets(ws_output)
lastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
For s = 9 To lastRow
If ws.Cells(s, 3) = CStr(ThisWorkbook.Sheets("HOME").Range("K11").value) Then
If ws.Cells(s, 16) = "0" Or ws.Cells(r, 16) = "" Then
ws.Cells(s, 16) = "1"
Debug.Print "GRADES: " & ws.Cells(s, 3) & " Verified!"
Else
Debug.Print "GRADES: " & ws.Cells(s, 3) & " Already Verified!"
End If
End If
Next s
Note that, this code will only work depends on the value of grd and qrt.
I'm thinking of using the code below as a start.
For Each ws In Sheets(Array("STUDENTS_INFO", "N-Q1", "N-Q2", "N-Q3", "N-Q4", "N-D", _
"JK-Q1", "JK-Q2", "JK-Q3", "JK-Q4", "JK-D", "SK-Q1", "SK-Q2", "SK-Q3", "SK-Q4", "SK-D"))
With ws.Cells(8, 3).CurrentRegion
.AutoFilter 2, LRN
ws.AutoFilterMode = False
End With
Next ws
Please see the code below for the solution that I came up. Thank you!
For Each ws In Sheets(Array("N-Q1", "N-Q2", "N-Q3", "N-Q4", "N-D", _
"JK-Q1", "JK-Q2", "JK-Q3", "JK-Q4", "JK-D", "SK-Q1", "SK-Q2", "SK-Q3", "SK-Q4", "SK-D"))
lastRow = ws.Cells(Rows.Count, "C").End(xlUp).Row
For r = 9 To lastRow
If ws.Cells(r, 3) = CStr(ThisWorkbook.Sheets("HOME").Range("K11").value) Then
If ws.Cells(r, 16) = "0" Or ws.Cells(r, 16) = "" Then
ws.Cells(r, 16) = "1"
Debug.Print "STUDENTS: " & ws.Cells(r, 3) & " Verified!"
Else
Debug.Print "STUDENTS: " & ws.Cells(r, 3) & " Already Verified!"
End If
End If
Next r
Next ws

Check checkbox value only once inside a nested loop

I am checking the value of a checkbox on my userform inside a nested loop. I want to know if there is a way to do this before the loops because basically the code is running the same check over and over again...
what it is doing is it loops through the entire column B and combines all the rows that have the same conditions. then it puts in into an array and prints. So I need to do this checkbox check twice. Any help is appreciated!
Dim dict As Object
Dim LastRow As Long
Dim aCell As Range
Dim ArrayLen As Long
Dim LArr() As Single
Dim MPch As Boolean
MPch = UserForm1.MPCheck1.Value
Set dict = CreateObject("scripting.dictionary")
X = 0
With wks
LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
ReDim LArr(LastRow)
For Each aCell In .Range("B2:B" & LastRow)
If MPch = True Then
UniqueCombo = aCell.Value & "," & aCell.Offset(0, 1) & aCell.Offset(0, 2)
Else
UniqueCombo = aCell.Value & "," & aCell.Offset(0, 1) & aCell.Offset(0, 2) & "," & aCell.Offset(0, 5)
End If
DieCoordinate = aCell.Value & "," & aCell.Offset(0, 1)
SheetName = aCell.Offset(0, 2) & "-" & aCell.Offset(0, 5)
If Not dict.exists(UniqueCombo) Then
VarLastRow = ThisWorkbook.Worksheets(SheetName).Cells(.Rows.Count, "E").End(xlUp).row + 1
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 5) = DieCoordinate
dict(UniqueCombo) = True 'add this value
For o = 2 To LastRow
If MPch = True Then
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4)
Else
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4) & "," & .Cells(o, 7)
End If
VariableCombo = .Cells(o, 2) & "," & .Cells(o, 3) & .Cells(o, 4) & "," & .Cells(o, 7)
If UniqueCombo = VariableCombo And .Cells(o, 6).Interior.ColorIndex = -4142 And _
.Cells(o, 6) <> "*" And .Cells(o, 6) <> "0" And .Cells(o, 6) <> "" Then
CDTot = CDTot + .Cells(o, 6)
LArr(X) = .Cells(o, 6)
X = X + 1
End If
Next
If X = 0 Then
ArrayLen = 0
Else
ReDim Preserve LArr(UBound(LArr) - (LastRow - X + 1))
ArrayLen = UBound(LArr) - LBound(LArr) + 1
End If
If ArrayLen < UserForm1.TextBox7 Then
ThisWorkbook.Worksheets(SheetName).Range(ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 5), ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 10)).Interior.ColorIndex = 53
End If
LCDUCD = 3 * Application.WorksheetFunction.StDev_P(LArr)
DieAver = Application.WorksheetFunction.Average(LArr)
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 7) = LCDUCD
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 6) = DieAver
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 8) = aCell.Value
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 9) = aCell.Offset(0, 1).Value
ThisWorkbook.Worksheets(SheetName).Cells(VarLastRow, 10) = ArrayLen
End If
ReDim LArr(LastRow)
X = 0
Next aCell
End With

How to sort multiple columns sequentially and have the rows merge for the same values?

I have a really crude code for sorting the columns out and merging them together as seen by my code. The first 3 blocks are to sort them first by column A, then column B, and then column C.
I want it so that users can see the breakdown in columns A, B and C. Column A being the material, B being the material variant, and C the fabrication method and not have to look at each entry row by row.
Is there a more efficient way of sorting the columns without having to go through the 3 blocks of code? And merging them at the end for me seems to not work as well and the rows end up getting mixed and not properly sorted.
Dim wsproc As Worksheet: Set wsproc = ThisWorkbook.Worksheets("Procurement Table")
For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
If _
wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
Then
wsproc.Rows(i3 - 1).Cut
wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
End If
Next
Next
For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
If _
wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
Then
wsproc.Rows(i3 - 1).Cut
wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
End If
Next
Next
For k3 = wsproc.UsedRange.Rows.Count To 2 Step -1
For i3 = wsproc.UsedRange.Rows.Count To 2 Step -1
If _
wsproc.Cells(k3, 1).Value = wsproc.Cells(i3 - 1, 1).Value _
And wsproc.Cells(k3, 2).Value = wsproc.Cells(i3 - 1, 2).Value _
And wsproc.Cells(k3, 3).Value = wsproc.Cells(i3 - 1, 3).Value _
Then
wsproc.Rows(i3 - 1).Cut
wsproc.Range("A1").End(xlDown).Offset(1, 0).EntireRow.Insert
End If
Next
Next
'To merge duplicate rows column-wise
Dim p As Variant
Dim iArray As Variant
Dim l%
iArray = Array(1, 2, 3)
ActiveSheet.ListObjects(1).Unlist
For Each p In iArray
For l = wsproc.UsedRange.Rows.Count To 2 Step -1
If wsproc.Cells(l, p).Value = wsproc.Cells(l - 1, p).Value _
Then
wsproc.Range(wsproc.Cells(l, p), wsproc.Cells(l - 1, p)).Merge
End If
Next
Next p
Range.Sort
Sub Main
Dim sheet as Worksheet: Set sheet = ThisWorkbook.Sheets("Sheet Name")
Dim lastRow as Long
Dim lastColumn as Integer
Dim sheetRange as Range
Dim sheetArray as Variant
Dim mergeRangesArray as Variant
Dim startRows as Variant
Dim i as Long
lastRow = sheet.UsedRange.Rows.Count
lastColumn = sheet.UsedRange.Columns.Count
'Assign the sheet's used range to a variable
Set sheetRange = sheet.Range(sheet.Cells(1, 1), sheet.Cells(lastRow, lastColumn))
'Use the Range.Sort method to sort
sheetRange.Sort key1:=sheet.Range("A1:A" & lastRow), order1:=xlAscending, _
key2:=sheet.Range("B1:B" & lastRow), order2:=xlAscending, _
key3:=sheet.Range("C1:C" & lastRow), order3:=xlAscending, Header:=xlYes
'Assign the sheet's range values to a 2D array
sheetArray = sheetRange
'Loop through the rows of the 2D array, and add ranges that need to be merged
'to the mergeRangesArray. The mergeRangesArray is an array of strings which
'are looped through at the end of the Sub to merge cells.
'The string argument for Range() has a character limit of 255.
startRows = Array(2, 2, 2)
For i = 3 to lastRow
If sheetArray(i, 1) <> sheetArray(i - 1, 1) Then
If i - startRows(0) > 1 Then
Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
If i - startRows(1) > 1 Then
Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
End If
If i - startRows(2) > 1 Then
Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
End If
End If
startRows = Array(i, i, i)
Else
If sheetArray(i, 2) <> sheetArray(i - 1, 2) Then
If i - startRows(1) > 1 Then
Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
End If
startRows(1) = i
End If
If sheetArray(i, 3) <> sheetArray(i - 1, 3) Then
If i - startRows(2) > 1 Then
Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
End If
startRows(2) = i
End If
End If
Next i
If i - startRows(0) > 1 Then
Call AddToRangeArray(mergeRangesArray, "A" & startRows(0) & ":A" & i - 1)
End If
If i - startRows(1) > 1 Then
Call AddToRangeArray(mergeRangesArray, "B" & startRows(1) & ":B" & i - 1)
End If
If i - startRows(2) > 1 Then
Call AddToRangeArray(mergeRangesArray, "C" & startRows(2) & ":C" & i - 1)
End If
Application.DisplayAlerts = False
For i = 1 to UBound(mergeRangesArray)
sheet.Range(mergeRangesArray(i)).Merge
Next i
Application.DisplayAlerts = True
End Sub
Sub AddToRangeArray(mergeRangesArray as variant, myString as string)
Dim i as Integer
Dim j as Integer
If IsEmpty(mergeRangesArray) = False Then
i = UBound(mergeRangesArray)
j = Len(mergeRangesArray(i))
If j + Len("," & myString) <= 255 Then
mergeRangesArray(i) = mergeRangesArray(i) & "," & myString
Else
ReDim Preserve mergeRangesArray(1 to i + 1)
mergeRangesArray(i + 1) = myString
End If
Else
ReDim mergeRangesArray(1 to 1)
mergeRangesArray(1) = myString
End If
End Sub

How to merge several cells using VBA

I have some problems with excel and VBA, in that don't know have much knowledge. I copied text from pdf and it's awful.
I have cells which contain some text.
The problem is that the text from one paragraph is broken down over several cells. At the beginning of each paragraph is a word in bold (e.g. CLR.) which describes the rest of the text. As such, it defines where each paragraph should start. How I can merge these cells into one?
I see
I want
Sub MergeText()
Dim strMerged$, r&, j&, i&
r = 1
Do While True
If Cells(r, 1).Characters(1, 1).Font.Bold Then
strMerged = "": strMerged = Cells(r, 1)
r = r + 1
While (Not Cells(r, 1).Characters(1).Font.Bold) And Len(Cells(r, 1)) > 0
strMerged = strMerged & Cells(r, 1)
r = r + 1
Wend
i = i + 1: Cells(i, 2) = strMerged
Cells(i, 2).Characters(1, InStr(1, strMerged, ".", vbTextCompare)).Font.Bold = True
Else
Exit Do
End If
Loop
End Sub
Modify (if needed) and try:
Option Explicit
Sub test()
Dim LastRow As Long, i As Long, j As Long, Count As Long
Dim str As String
With ThisWorkbook.Worksheets("Sheet1") 'Change sheet name if needed
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1
If (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) = Left(.Range("A" & i - 1), 1) Then
Count = 0
For j = 1 To Len(.Range("A" & i - 1))
If .Range("A1").Characters(j, 1).Font.FontStyle = "Bold" Then
Count = Count + 1
Else
Exit For
End If
Next j
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
With .Characters(Start:=1, Length:=Count).Font
.FontStyle = "Bold"
End With
End With
.Rows(i).EntireRow.Delete
ElseIf (UCase(Left(.Range("A" & i), 1)) <> Left(.Range("A" & i), 1)) And UCase(Left(.Range("A" & i - 1), 1)) <> Left(.Range("A" & i - 1), 1) Then
str = .Range("A" & i - 1).Value & " " & .Range("A" & i).Value
With .Range("A" & i - 1)
.Value = str
.Font.Bold = False
End With
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub

Dynamic first and last row of a range

I am surprised there's no answer for this. I have read Setting Dynamic Ranges in VBA and Selecting Dynamic Range and Autofill Dynamic Range Last Row and Last Column and MSDN
I have multiple, distinct ranges on a sheet with varying sizes. I am trying to subtotal column L. I can do it using a hardcoded sum (via subtotal variable) but I want to insert a formula into the cell instead. This requires knowing the starting and end rows for each range. My code almost works. It fails when the range only consists of one row. Even so, I feel there's gotta be a smarter way to do this.
How does one determine the start and end row of a range on a sheet filled with multiple ranges?
For i = 2 To j
If .Cells(i + 1, "L") = "" And .Cells(i + 2, "L") = "" Then
b = .Cells(i - 1, "J").End(xlUp).Row
End If
subtotal = subtotal + .Cells(i, "L").Value2
If .Cells(i, 1) = "" And .Cells(i - 1, "B") <> "" Then
If .Cells(i - 1, "K") = 0 Then
.Cells(i, "K").Value2 = "Check Payment"
'Set sumRng = .Range(.Cells(b, "L"), .Cells(i - 1, "L"))
.Cells(i, "L").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
.Cells(i - 1, "L").Borders(xlEdgeBottom).LineStyle = xlContinuous
total = total + subtotal
subtotal = 0
ElseIf .Cells(i - 1, "K") = "Checking" Then
.Cells(i, "K").Value2 = "EFT Payment"
'Set sumRng = .Range(.Cells(b, "L"), .Cells(i - 1, "L"))
.Cells(i, "L").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
.Cells(i - 1, "L").Borders(xlEdgeBottom).LineStyle = xlContinuous
total = total + subtotal
subtotal = 0
End If
End If
Next
You can loop through the column like this:
For i = 2 To mySheet.Range("B" & Rows.Count).End(xlUp).Row + 1
If Range("B" & i).Value <> vbNullString Then
If Range("B" & i - 1).Value = vbNullString Then
j = i
End If
Else
If Range("B" & i - 1).Value <> vbNullString And Range("B" & i - 1).Formula <> "=SUM(B" & j & ":B" & i - 2 & ")" Then
Range("B" & i).Formula = "=SUM(B" & j & ":B" & i - 1 & ")"
End If
End If
Next i
This uses Match to skip chunks and as such the number or loops are less
With ActiveSheet
Dim b As Long
b = 2
Do Until b = .Rows.Count
Dim x As Variant
x = .Evaluate("Match(True, Index(" & .Range(.Cells(b, "l"), .Cells(.Rows.Count, "l")).Address & " <> """",),0)")
If Not IsError(x) Then
b = b + x - 1
Else
Exit Sub
End If
x = .Evaluate("Match(True, Index(" & .Range(.Cells(b, "l"), .Cells(.Rows.Count, "l")).Address & " = """",),0)")
Dim i As Long
i = b + x - 1
.Cells(i, "l").Formula = "=sum(L" & b & ":L" & i - 1 & ")"
b = i + 2
Loop
End With

Resources