I have some confusion about excel vba. My aim is to determine which shipments are exceed of the daily carton pick capacity or pallet pick capacity. Each month has different carton and pallet amount.
For Each cell In Range("AB2:AB10000")
For i = 2 To 10000
If Mid(cell.Value, 4, 2) = "01" Then
toplam_karton_ocak = toplam_karton_ocak - Cells(i, 20)
toplam_palet_ocak = toplam_palet_ocak - cell(i, 19)
If toplam_palet_ocak < 0 Or toplam_karton_ocak < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
I used "for each " to check every cell in the column and I used 12 "if" conditions to assign date to the right capacity. I tried to decrease the capacity when every shipment came. My aim is that if pallet or carton pick is less than zero, giving a message on the screen.
Mid(cell.Value, 4, 2) --> It takes 4th and 5th digits of the day. i.e the date is "22.05.2020".It receives "05" and that means "may"
My problem is I could not do this for every day. I just did it for month but it is useless because i have to check it separately for every single day. What should i do?
You can find the full code below:
Sub New_DC()
New_DC Makro
Range("Z1").Select
ActiveCell.FormulaR1C1 = "BOOKING ONLY DATES"
Range("Z2").Select
ActiveCell.FormulaR1C1 = "=LEFT([#[BOOKING_DATE_OR]],8)"
Range("AA1").Select
ActiveCell.FormulaR1C1 = "Column1 "
Range("AA2").Select
ActiveCell.FormulaR1C1 = _
"=DATE(RIGHT([#[BOOKING ONLY DATES]],4),MID([#[BOOKING ONLY DATES]],3,2),LEFT([#[BOOKING ONLY DATES]],2))"
Range("AB1").Select
ActiveCell.FormulaR1C1 = "New DC"
Range("AB2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-14]=""1-YES"",IF(ISBLANK([#[Sum of Carrier Lead Time]]),[#[Column1 ]]-[#[Sum of TRANSPORT_DURATION]],[#[Column1 ]]-[#[Sum of Carrier Lead Time]]),IF(ISBLANK([#[Sum of Carrier Lead Time]]),[#[END_TIME_UTC]]-[#[Sum of TRANSPORT_DURATION]],[#[END_TIME_UTC]]-[#[Sum of Carrier Lead Time]]))"
Columns("AB:AB").Select
Selection.NumberFormat = "m/d/yyyy"
Columns("Z:AA").Select
Selection.EntireColumn.Hidden = True
Range("AE11").Select
Range("Table1[[#Headers],[New DC]]").Select
ActiveWorkbook.Worksheets("Data").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data").ListObjects("Table1").Sort.SortFields.Add2 _
Key:=Range("Table1[[#Headers],[New DC]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Data").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("AC2").Select
ActiveCell.FormulaR1C1 = _
"=IF([#[Booking_Appointment_Made (groups)]]=""1-YES"",1,0)"
Range("AC2").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Data").ListObjects("Table1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Data").ListObjects("Table1").Sort.SortFields.Add2 _
Key:=Range("AC2"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Data").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("AC:AC").Select
Selection.EntireColumn.Hidden = True
Range("AB2").Select
Dim toplam_karton_ocak As Long, toplam_karton_subat As Long, toplam_karton_mart As Long, toplam_karton_nisan As Long
Dim toplam_karton_mayis As Long, toplam_karton_haziran As Long, toplam_karton_temmuz As Long, toplam_karton_agustos As Long
Dim toplam_karton_eylul As Long, toplam_karton_ekim As Long, toplam_karton_kasim As Long, toplam_karton_aralik As Long
Dim toplam_palet_ocak As Integer, toplam_palet_subat As Integer, toplam_palet_mart As Integer, toplam_palet_nisan As Integer
Dim toplam_palet_mayis As Integer, toplam_palet_haziran As Integer, toplam_palet_temmuz As Integer, toplam_palet_agustos As Integer
Dim toplam_palet_eylul As Integer, toplam_palet_ekim As Integer, toplam_palet_kasim As Integer, toplam_palet_aralik As Integer
toplam_karton_ocak = 15000
toplam_palet_ocak = 300
toplam_karton_subat = 15000
toplam_palet_subat = 300
toplam_karton_mart = 15000
toplam_palet_mart = 300
toplam_karton_nisan = 17000
toplam_palet_nisan = 400
toplam_karton_mayis = 17500
toplam_palet_mayis = 600
toplam_karton_haziran = 18000
toplam_palet_haziran = 300
toplam_karton_temmuz = 20000
toplam_palet_temmuz = 300
toplam_karton_agustos = 25000
toplam_palet_agustos = 500
toplam_karton_eylul = 42000
toplam_palet_eylul = 900
toplam_karton_ekim = 35000
toplam_palet_ekim = 750
toplam_karton_kasim = 27000
toplam_palet_kasim = 750
toplam_karton_aralik = 22500
toplam_palet_aralik = 750
For Each cell In Range("AB2:AB10000")
For i = 2 To 10000
If Mid(cell.Value, 4, 2) = "01" Then
toplam_karton_ocak = toplam_karton_ocak - Cells(i, 20)
toplam_palet_ocak = toplam_palet_ocak - cell(i, 19)
If toplam_palet_ocak < 0 Or toplam_karton_ocak < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "02" Then
toplam_karton_subat = toplam_karton_subat - Cells(i, 20)
toplam_palet_subat = toplam_palet_subat - Cells(i, 19)
If toplam_palet_subat < 0 Or toplam_karton_subat < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "03" Then
toplam_karton_mart = toplam_karton_mart - Cells(i, 20)
toplam_palet_mart = toplam_palet_mart - Cells(i, 19)
If toplam_palet_mart < 0 Or toplam_karton_mart < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "04" Then
toplam_karton_nisan = toplam_karton_nisan - Cells(i, 20)
toplam_palet_nisan = toplam_palet_nisan - Cells(i, 19)
If toplam_palet_nisan < 0 Or toplam_karton_nisan < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "05" Then
toplam_karton_mayis = toplam_karton_mayis - Cells(i, 20)
toplam_palet_mayis = toplam_palet_mayis - Cells(i, 19)
If toplam_palet_mayis < 0 Or toplam_karton_mayis < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "06" Then
toplam_karton_haziran = toplam_karton_haziran - Cells(i, 20)
toplam_palet_haziran = toplam_palet_haziran - Cells(i, 19)
If toplam_palet_haziran < 0 Or toplam_karton_haziran < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "07" Then
toplam_karton_temmuz = toplam_karton_temmuz - Cells(i, 20)
toplam_palet_temmuz = toplam_palet_temmuz - Cells(i, 19)
If toplam_palet_temmuz < 0 Or toplam_karton_temmuz < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "08" Then
toplam_karton_agustos = toplam_karton_agustos - Cells(i, 20)
toplam_palet_agustos = toplam_palet_agustos - Cells(i, 19)
If toplam_palet_agustos < 0 Or toplam_karton_agustos < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "09" Then
toplam_karton_eylul = toplam_karton_eylul - Cells(i, 20)
toplam_palet_eylul = toplam_palet_eylul - Cells(i, 19)
If toplam_palet_eylul < 0 Or toplam_karton_eylul < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "10" Then
toplam_karton_ekim = toplam_karton_ekim - Cells(i, 20)
toplam_palet_ekim = toplam_palet_ekim - Cells(i, 19)
If toplam_palet_ekim < 0 Or toplam_karton_ekim < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "11" Then
toplam_karton_kasim = toplam_karton_kasim - Cells(i, 20)
toplam_palet_kasim = toplam_palet_kasim - Cells(i, 19)
If toplam_palet_kasim < 0 Or toplam_karton_kasim < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
ElseIf Mid(cell.Value, 4, 2) = "12" Then
toplam_karton_aralik = toplam_karton_aralik - Cells(i, 20)
toplam_palet_aralik = toplam_palet_aralik - Cells(i, 19)
If toplam_palet_aralik < 0 Or toplam_karton_aralik < 0 Then
MsgBox (Cells(i, 1).Value & " nolu shipment kapasiteyi aşmaktadır.")
End If
End If
Next i
Next cell
Columns("AB:AB").Select
Range("AF6").Select
End Sub
Thanks for your help :)
Related
hi I have a table that I schedule workers at the workers are scheduled at a range of hours for example 11:00-18:00 and a range of dates for example 21/01/2021-26/01/2021
and I need to spot duplicates for example if the same worker is scheduled at 21/04/2021-22/04/2021 at 11:00:18:00 and 13:00-15:00 it would detect a duplicate schedule
the table looks like this
my code right now spots only exact same schedule duplicate or once that start at the same hour
Private Sub CommandButton1_Click()
Dim lrow As Long
Dim x As Integer
Dim y As Integer
Dim i As Integer
lrow = ActiveSheet.ListObjects("LeaveTracker").DataBodyRange.Rows.Count + 5
shibuzim.ListObjects("LeaveTracker").ListColumns(2).DataBodyRange.Clear
For x = 5 To lrow
For y = x + 1 To lrow
If (Cells(x, 12).Value = Cells(y, 12).Value And _
Cells(x, 13).Value = Cells(y, 13).Value And _
Cells(x, 14).Value = Cells(y, 14).Value And _
Cells(x, 17).Value = Cells(y, 17).Value And _
Cells(x, 18).Value = Cells(y, 18).Value And _
Cells(x, 20).Value = Cells(y, 20).Value) _
Or _
(Cells(x, 12).Value = Cells(y, 12).Value And _
Cells(x, 13).Value = Cells(y, 13).Value And _
Cells(x, 14).Value = Cells(y, 14).Value And _
Left(Cells(x, 17).Value, 3) = Left(Cells(y, 17).Value, 3) And _
Cells(x, 18).Value = Cells(y, 18).Value And _
Cells(x, 20).Value = Cells(y, 20).Value) _
Then
Cells(x, 11).Value = "duplicate"
Cells(y, 11).Value = "duplicate"
MsgBox "line" & " " & x - 4 & " " & "with line" & " " & y - 4
End If
Next y
Next x
End Sub
This create a list of all shifts on a sheet named Check , sorts them by employee, start date, days and then checks them for shifts that start before the previous one ended.
Option Explicit
Sub CheckDupl()
Const COL_DUPL = 2 ' table column 2
Const COl_EMPLOYEE = 3
Const COL_START = 4
Const COL_END = 5
Const COL_HOURS = 8
Dim wb As Workbook, ws As Worksheet, wsCheck As Worksheet
Dim tbl As ListObject, lrow As Long
Dim r As Long, p As Long, iDupl As Long, count As Long
' clear table
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' or wb.ActiveSheet
Set tbl = ws.ListObjects("LeaveTracker")
With tbl
lrow = .DataBodyRange.Rows.count
.ListColumns(COL_DUPL).DataBodyRange.Clear
End With
Dim sEmploy As String, s As String
Dim dtStart As Date, dtEnd As Date, dt As Date
Dim bDupl As Boolean, arHours, dur As Single
' prepare output sheet
Set wsCheck = wb.Sheets("Check")
wsCheck.Cells.Clear
wsCheck.Range("A1:F1") = Array("Employee", "Shift Start", "Shift End ", _
"Days", "Table Row", "Duplicate")
' scan table
iDupl = 2
For r = 1 To lrow
sEmploy = Trim(tbl.DataBodyRange(r, COl_EMPLOYEE))
dtStart = tbl.DataBodyRange(r, COL_START)
dtEnd = tbl.DataBodyRange(r, COL_END)
' get shift start/end times
s = Replace(tbl.DataBodyRange(r, COL_HOURS), " ", "") 'remove spaces
If Not s Like "##:##-##:##" Then
MsgBox "Check times '" & s & "'", vbCritical, "Table Row " & r
Exit Sub
Else
arHours = Split(s, "-")
End If
' add each shift to duplicate sheet
dt = dtStart
Do While dt <= dtEnd
With wsCheck.Cells(iDupl, 1)
.Value = sEmploy
.Offset(, 1) = CDate(Format(dt, "yyyy-mm-dd ") & arHours(0))
.Offset(, 2) = CDate(Format(dt, "yyyy-mm-dd ") & arHours(1))
.Offset(, 3) = dtEnd - dtStart
.Offset(, 4) = r ' table row
' sanity check
If .Offset(, 2) - .Offset(, 1) < 0 Then
MsgBox "ERROR - End date before Start date for " & _
sEmploy, vbCritical, "Table Row " & r
Exit Sub
End If
End With
dt = dt + 1
iDupl = iDupl + 1
Loop
Next
iDupl = iDupl - 1
' sort calendar by employee, start date, days
' check longer date ranges against shorter ones
With wsCheck.Sort
With .SortFields
.Clear
.Add key:=Range("A2:A" & iDupl), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("B2:B" & iDupl), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Add key:=Range("D1:D" & iDupl), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A1:F" & iDupl)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' now check for overlaps
With wsCheck
p = 2
For r = 3 To iDupl
' check start is before previous end for same employee
If .Cells(r, 1) = .Cells(p, 1) _
And .Cells(r, 2) < .Cells(p, 3) Then
.Cells(r, 6) = "Overlap with row " & p
' update table
tbl.DataBodyRange(.Cells(r, 5), COL_DUPL) = "Duplicate"
count = count + 1
Else
p = r
End If
Next
.Columns("A:F").AutoFit
.Activate
.Range("A1").Select
End With
MsgBox count & " duplicates found - see sheet " & wsCheck.Name, vbInformation
End Sub
Hello Everyone. I'm new to VBA and I keep getting an error that says "Compile error:
For without Next"
Sub Aplhabetical_Testing()
Dim ws As Worksheet
Dim ticker As String
Dim vol As Integer
Dim year_open As Double
Dim year_close As Double
Dim yearly_change As Double
Dim percent_change As Double
Dim total_stock_volume As Double
For Each ws In Worksheet
ws.Range("I1").Value = "Ticker"
ws.Range("J1").Value = "Yearly Change"
ws.Range("K1").Value = "Percent Change"
ws.Range("L1").Value = "Total Stock Volume"
ws.Range("P1").Value = "Ticker"
ws.Range("Q1").Value = "Value"
ws.Range("O2").Value = "Greatest % Increase"
ws.Range("O3").Value = "Greatest % Decrease"
ws.Range("O4").Value = "Greatest Total Volume"
For i = 2 To RowCount
j = 0
total = 0
Change = 0
Start = 2
If Cells(i + 1, 1).Value <> Cells(i, 7).Value Then
total = total + Cells(i, 7).Value
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = 0
Range("K" & 2 + j).Value = "%" & 0
Range("L" & 2 + j).Value = 0
Else
If Cells(Start, 3) = 0 Then
For find_value = Start To i
If Cells(find_value, 3).Value <> 0 Then
Start = find_value
Exit For
End If
Next find_value
End If
Change = (Cells(i, 6) - Cells(Start, 3))
percentChange = Round((Change / Cells(Start, 3) * 100), 2)
Start = i + 1
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = Round(Change, 2)
Range("K" & 2 + j).Value = "%" & percentChange
Range("L" & 2 + j).Value = total
Select Case Change
Case Is > 0
Range("j" & 2 + j).Interior.ColorIndex = 4
Case Is < 0
Range("j" & 2 + j).Interior.ColorIndex = 3
Case Else
Range("j" & 2 + j).Interior.ColorIndex = 0
End Select
End If
End Sub
There are a number of statements in VBA which must be properly terminated. For instance,
Sub / End Sub,
Function / End Function,
If / End If.
With / End With, or
Enum / End Enum
For better code readability everything between the statement and the End should be indented, like this:-
Sub MySub()
' Here is my code
End Sub
or
If 1 < 2 Then
' Here is what to do in that case
End If
For / Next and Do / Loop work exactly the same way. For example,
For i = 1 to 10
' code to be executed *i* times
Next i
The concepts can be nested. Here's an example.
Private Sub MySub()
Dim i As Integer
For i = 1 to 10
If i = 5 then
Debug.Print "Half done"
End if
Next i
End Sub
You miss two Next:
Sub Aplhabetical_Testing()
Dim ws As Worksheet
Dim ticker As String
Dim vol As Integer
Dim year_open As Double
Dim year_close As Double
Dim yearly_change As Double
Dim percent_change As Double
Dim total_stock_volume As Double
For Each ws In Worksheet ' Worksheets?
ws.Range("I1").Value = "Ticker"
ws.Range("J1").Value = "Yearly Change"
ws.Range("K1").Value = "Percent Change"
ws.Range("L1").Value = "Total Stock Volume"
ws.Range("P1").Value = "Ticker"
ws.Range("Q1").Value = "Value"
ws.Range("O2").Value = "Greatest % Increase"
ws.Range("O3").Value = "Greatest % Decrease"
ws.Range("O4").Value = "Greatest Total Volume"
For i = 2 To RowCount
j = 0
total = 0
Change = 0
Start = 2
If Cells(i + 1, 1).Value <> Cells(i, 7).Value Then
total = total + Cells(i, 7).Value
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = 0
Range("K" & 2 + j).Value = "%" & 0
Range("L" & 2 + j).Value = 0
Else
If Cells(Start, 3) = 0 Then
For find_value = Start To i
If Cells(find_value, 3).Value <> 0 Then
Start = find_value
Exit For
End If
Next find_value
End If
Change = (Cells(i, 6) - Cells(Start, 3))
percentChange = Round((Change / Cells(Start, 3) * 100), 2)
Start = i + 1
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = Round(Change, 2)
Range("K" & 2 + j).Value = "%" & percentChange
Range("L" & 2 + j).Value = total
Select Case Change
Case Is > 0
Range("j" & 2 + j).Interior.ColorIndex = 4
Case Is < 0
Range("j" & 2 + j).Interior.ColorIndex = 3
Case Else
Range("j" & 2 + j).Interior.ColorIndex = 0
End Select
End If
' Missing Next
Next
' Missing Next
Next
End Sub
I have a userform with multiple comboboxes that I want to use to record data on a worksheet. How do I write the code in a loop so I do not have to write it for all 60 occurances? Below is an example of what I have:
Edited to add the whole sub:
Private Sub FltData_Click()
'Check for empty date boxes
Dim IsEmptyDateBox As Boolean
IsEmptyDateBox = IsBlankDateBox()
If IsEmptyDateBox = True Then
MsgBox "Empty Date Box Detected"
End If
'Check for complete training boxes
Dim IsEmptyTextBox As Boolean
IsEmptyTextBox = IsBlankTextBox()
If IsEmptyTextBox = True Then
MsgBox "Incomplete Training Info Detected"
End If
'Input date function
Dim DateSelect As String
Dim Month As String
Dim Day As String
Dim Year As String
If DateMonth.Value = "January" Then
Month = "01"
Elseif DateMonth.Value = "February" Then
Month = "02"
Elseif DateMonth.Value = "March" Then
Month = "03"
Elseif DateMonth.Value = "April" Then
Month = "04"
Elseif DateMonth.Value = "May" Then
Month = "05"
Elseif DateMonth.Value = "June" Then
Month = "06"
Elseif DateMonth.Value = "July" Then
Month = "07"
Elseif DateMonth.Value = "August" Then
Month = "08"
Elseif DateMonth.Value = "September" Then
Month = "09"
Elseif DateMonth.Value = "October" Then
Month = "10"
Elseif DateMonth.Value = "November" Then
Month = "11"
Elseif DateMonth.Value = "December" Then
Month = "12"
End If
Day = DateDay.Value
Year = DateYear.Value
DateSelect = Month + "/" + Day + "/" + Year
'Is data already inputed/eliminate duplicates
Call DuplicateCheck
'Select FltData worksheet
Worksheets("FltData").Select
'Select blank row after last entry
LastRow = Worksheets("FltData").UsedRange.SpecialCells(xlCellTypeLastRow).Row
Cells(LastRow + 1,1).Select
'Input UserForm info to Worksheet
ActiveCell.Value = DateSelect
ActiveCell.Offset(, 1).Value = Time1.Value
ActiveCell.Offset(, 2).Value = Crew1.Value
ActiveCell.Offset(, 3).Value = TR1.Value
ActiveCell.Offset(, 4).Value = Status1.Value
If Time2.Value <> "" Then
ActiveCell.Offset(1, 0).Value = DateSelect
ActiveCell.Offset(1, 1).Value = Time2.Value
ActiveCell.Offset(1, 2).Value = Crew2.Value
ActiveCell.Offset(1, 3).Value = TR2.Value
ActiveCell.Offset(1, 4).Value = Status2.Value
End If
If Time3.Value <> "" Then
ActiveCell.Offset(2, 0).Value = DateSelect
ActiveCell.Offset(2, 1).Value = Time3.Value
ActiveCell.Offset(2, 2).Value = Crew3.Value
ActiveCell.Offset(2, 3).Value = TR3.Value
ActiveCell.Offset(2, 4).Value = Status3.Value
End If
If Time4.Value <> "" Then
ActiveCell.Offset(3, 0).Value = DateSelect
ActiveCell.Offset(3, 1).Value = Time4.Value
ActiveCell.Offset(3, 2).Value = Crew4.Value
ActiveCell.Offset(3, 3).Value = TR4.Value
ActiveCell.Offset(3, 4).Value = Status4.Value
End If
Call SortByDateTime
End Sub
...
I think I figured out a way to get this done by using Me.Controls:
Dim x As Integer
Dim y As Integer
Dim z As Integer
x = 1
y = 2
For y = 2 To 48
If Me.Controls("Time" & y).Value <> "" Then
ActiveCell.Offset(x, 0).Value = DateSelect
ActiveCell.Offset(x, 1).Value = Me.Controls("Time" & y).Value
ActiveCell.Offset(x, 2).Value = Me.Controls("Crew" & y).Value
ActiveCell.Offset(x, 3).Value = Me.Controls("TR" & y).Value
ActiveCell.Offset(x, 4).Value = Me.Controls("Status" & y).Value
End If
x = x + 1
Next y
I have a code which builds a table based on the data in another sheet. In this sheet there are three columns - Time, URN and Location. Time is shown as HH:MM:SS, URN is a 4 digit number and Location is a postcode displayed in the usual format.
I have normally used this code with a Date instead of time, but I have been trying to use it with time. I have made a slight adjustment after declaring the date as a variable, adding in the time value part.
I am now getting a
Run-time error '91': Object variable or With block variable not set,
with the following highlighted:
.Cells(FndDt.Row, FndNum.Column) = "P"
I have tried removing this piece of code and adding in a On Error Resume Next but I then get an error on the lines above or below it.
Option Explicit
Sub chrisellis250()
Dim Dt, Urn, i As Long, x As Long, lr As Long, lc As Long: x = 2
Dim colwidth As Long
Dim FndDt As Range, FndNum As Range, Dat As Date, Num As String, Loc As String
Dat = TimeValue("00:00:00")
Application.ScreenUpdating = False
With Sheet2
lr = .Cells(.Rows.Count, 2).End(xlUp).Row
.Range(.Cells(2, 1), .Cells(.Rows.Count, 1)).AdvancedFilter xlFilterCopy, , .Range("E1"), True
With .Range("E1").CurrentRegion: Dt = .Value: End With
Sheet1.Range("A3").Resize(UBound(Dt) - 1) = .Range("E2:E" & UBound(Dt)).Value: .Columns(5).Clear
Sheet1.Range("A3").Resize(UBound(Dt) - 1).Interior.ColorIndex = 15
.Range(.Cells(2, 2), .Cells(.Rows.Count, 2)).AdvancedFilter xlFilterCopy, , .Range("E1"), True
With .Range("E1").CurrentRegion: Urn = .Value: End With
For i = 1 To 2
Sheet1.Cells(2, x).Resize(, UBound(Urn) - 1) = Application.WorksheetFunction.Transpose(.Range("E2:E" & UBound(Urn)).Value)
If i = 1 Then colwidth = 8.3 Else colwidth = 55
Sheet1.Cells(2, x).Resize(, UBound(Urn) - 1).ColumnWidth = colwidth
If x = 2 Then Sheet1.Cells(1, x) = "URN" Else Sheet1.Cells(1, x) = "XXXXX"
Sheet1.Cells(1, x).Resize(, UBound(Urn) - 1).MergeCells = True
Sheet1.Cells(1, x).Resize(, UBound(Urn) - 1).Interior.ColorIndex = 15
x = x + UBound(Urn) - 1
Next i
.Columns(5).Clear
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Range("B" & i) <> "" Then
Dat = .Range("A" & i): Num = .Range("B" & i): Loc = .Range("C" & i)
With Sheet1
.Range("B3").Resize(lr, UBound(Urn) - 1).Font.Name = "Wingdings 2"
lc = .Cells(2, .Columns.Count).End(xlToLeft).Column
Set FndDt = .Range("A:A").Find(Dat, LookIn:=xlValues, lookat:=xlWhole)
Set FndNum = .Range(.Cells(2, 1), .Cells(2, lc)).Find(Num, LookIn:=xlValues, lookat:=xlWhole)
.Cells(FndDt.Row, FndNum.Column) = "P": .Cells(FndDt.Row, FndNum.Column).Font.Color = vbGreen
On Error Resume Next
If Not .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) Like "*" & Loc & "*" Then
.Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) = IIf(.Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) = "", Loc, .Cells(FndDt.Row, FndNum.Column + UBound(Urn) - 1) & "," & Loc)
End If
End With
End If
Next i
With Sheet1
With .Range("B3").Resize(UBound(Dt) - 1, UBound(Urn) - 1)
.SpecialCells(xlCellTypeBlanks).Font.Color = vbRed: .SpecialCells(xlCellTypeBlanks).Value = "O":
End With
With .Range("B3").Offset(, UBound(Urn) - 1).Resize(UBound(Urn) - 1, UBound(Urn) - 1)
.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 15
End With
AddOutsideBorders .Range("A1").Resize(UBound(Dt) + 1, 1 + ((UBound(Urn) - 1) * 2))
With .Cells
.Columns.AutoFit
.HorizontalAlignment = xlCenter
.RowHeight = 25
End With
End With
End With
Application.ScreenUpdating = True
End Sub
Public Function AddOutsideBorders(rng As Range)
With rng.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
End Function
Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 9 years ago.
Improve this question
I need someone to save me on this one. I'm not a developer; I'm a QA. However, I've been tasked with creating a script that will take the mass data from one xlsx and creating new xlsx documents based on salesman, customer, and branch location. I have the code working, but it will take days for it to run if the computer it is running on does not run out of memory. I will post the code I have below. Is there any way to optimize it in order to run faster? We need it by Friday morning. Let me reiterate, I'm a QA. If you say do this or do that, I have no idea what you are talking about. I literally need "replace this with this". You guys have been awesome in you help so far, and I can't thank you enough. I don't know why you do what you do, but thank you for doing it.
Option Explicit
' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
Dim Sheet As Worksheet
Dim Key As String
Dim Result As Worksheet: Set Result = Nothing
Key = UCase(Name)
' loop over all the worksheets
For Each Sheet In Book.Worksheets
' break out of the loop if the sheet is found
If UCase(Sheet.Name) = Key Then
Set Result = Sheet
Exit For
End If
Next Sheet
' if the sheet isn't found..
If Result Is Nothing Then
If Ignore = False Then
If Not GetSheet("Sheet1", Book, True) Is Nothing Then
' rename sheet1
Set Result = Book.Worksheets("Sheet1")
Result.Name = Name
End If
Else
' create a new sheet
Set Result = Book.Worksheets.Add
Result.Name = Name
End If
Result.Cells(1, 1) = "Rank"
Result.Cells(1, 2) = "Customer Segment"
Result.Cells(1, 3) = "Salesrep Name"
Result.Cells(1, 4) = "Main_Customer_NK"
Result.Cells(1, 5) = "Customer"
Result.Cells(1, 6) = "FY13 Sales"
Result.Cells(1, 7) = "FY13 Inv Cost GP$"
Result.Cells(1, 8) = "FY13 Inv Cost GP%"
Result.Cells(1, 9) = "Sales Growth"
Result.Cells(1, 10) = "GP Point Change"
Result.Cells(1, 11) = "Sales % Increase"
Result.Cells(1, 12) = "Budgeted Total Sales"
Result.Cells(1, 13) = "Budget GP%"
Result.Cells(1, 14) = "Budget GP$"
Result.Cells(1, 15) = "Target Account"
Result.Cells(1, 16) = "Estimated Total Purchases"
Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
Result.Cells(1, 18) = "Notes"
Result.Cells(1, 19) = "Reference 1"
Result.Cells(1, 20) = "Reference 2"
'and the rest....
End If
Set GetSheet = Result
End Function
Sub Main()
Dim Source As Worksheet
Dim Location As Workbook
Dim Sales As Worksheet
Dim LocationKey As String
Dim SalesKey As String
Dim Index As Variant
Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
Dim Row As Long
Dim InsertPos As Long
Set Source = ThisWorkbook.ActiveSheet
Row = 2 ' Skip header row
Do
' break out of the loop - assumes that the first empty row signifies the end
If Source.Cells(Row, 1).Value2 = "" Then
Exit Do
End If
LocationKey = Source.Cells(Row, 3).Value2
' look at the location, and find the workbook, creating it if required
If Map.Exists(LocationKey) Then
Set Location = Map(LocationKey)
Else
Set Location = Application.Workbooks.Add(xlWBATWorksheet)
Map.Add LocationKey, Location
End If
SalesKey = Source.Cells(Row, 5).Value2
' get the sheet for the salesperson
Set Sales = GetSheet(SalesKey, Location)
' Get the location to enter the data
InsertPos = Sales.Range("A1").End(xlDown).Row + 1
'check to see if it's a new sheet, and adjust
If InsertPos = 1048577 Then
'Stop
InsertPos = 2
'change to 65537 is using excel 2003 or before
Macro1
End If
' populate said row with the data from the source
Sales.Cells(InsertPos, 1).Value2 = Source.Cells(Row, 1)
Sales.Cells(InsertPos, 2).Value2 = Source.Cells(Row, 2)
Sales.Cells(InsertPos, 3).Value2 = Source.Cells(Row, 5)
Sales.Cells(InsertPos, 4).Value2 = Source.Cells(Row, 6)
Sales.Cells(InsertPos, 5).Value2 = Source.Cells(Row, 7)
Sales.Cells(InsertPos, 6).Value2 = Source.Cells(Row, 8)
Sales.Cells(InsertPos, 7).Value2 = Source.Cells(Row, 9)
Sales.Cells(InsertPos, 8).Value2 = Source.Cells(Row, 10)
Sales.Cells(InsertPos, 9).Value2 = Source.Cells(Row, 11)
Sales.Cells(InsertPos, 10).Value2 = Source.Cells(Row, 12)
Sales.Cells(InsertPos, 11).Value2 = Source.Cells(Row, 13)
Sales.Cells(InsertPos, 12).Value2 = Source.Cells(Row, 14)
Sales.Cells(InsertPos, 13).Value2 = Source.Cells(Row, 15)
Sales.Cells(InsertPos, 14).Value2 = Source.Cells(Row, 16)
Sales.Cells(InsertPos, 19).Value2 = Source.Cells(Row, 17)
Sales.Cells(InsertPos, 20).Value2 = Source.Cells(Row, 18)
Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"
'increment the loop
'Range("H" & InsertPos).Activate
'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))
'Range("I" & InsertPos).Activate
'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)
'Range("J" & InsertPos).Activate
'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))
Row = Row + 1
Macro2 'runs on each cell
Loop
' loop over the resulting workbooks and save them - using the location name as file name
For Each Index In Map.Keys
Set Location = Map(Index)
Location.SaveAs Filename:=Index
Next Index
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
Cells.Select
Cells.EntireColumn.AutoFit
Columns("F:G").Select
Selection.NumberFormat = "$#,##0.00"
ActiveWindow.SmallScroll ToRight:=3
Columns("H:J").Select
Selection.NumberFormat = "0.00%"
Selection.NumberFormat = "0.0%"
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
Range("K:K,M:M").Select
Range("M1").Activate
Selection.NumberFormat = "0.0%"
Range("N:N,L:L").Select
Range("L1").Activate
Selection.NumberFormat = "$#,##0.00"
ActiveWindow.SmallScroll ToRight:=5
Columns("S:T").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=-4
Range("K:K,M:M").Select
Range("M1").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Cells.Select
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Cells.Select
'Range("L9").Activate
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Cells.Select
'Cells.EntireColumn.AutoFit
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub
Sub Macro2()
'
' Macro2 Macro
'
'
Cells.EntireColumn.AutoFit
Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub
Just got rid of some select statements, added some loops, and turned off screen updating and set calculation to manual while executing. I have added some comments here and there, check them out too. See if that helps
Option Explicit
Sub Main()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Source As Worksheet
Dim Location As Workbook
Dim Sales As Worksheet
Dim LocationKey As String
Dim SalesKey As String
Dim Index As Variant
Dim Map As Object: Set Map = CreateObject("Scripting.Dictionary")
Dim Row As Long
Dim InsertPos As Long
Set Source = ThisWorkbook.ActiveSheet
Row = 2 ' Skip header row
Do
' break out of the loop - assumes that the first empty row signifies the end
If Source.Cells(Row, 1).Value2 = "" Then
Exit Do
End If
LocationKey = Source.Cells(Row, 3).Value2
' look at the location, and find the workbook, creating it if required
If Map.Exists(LocationKey) Then
Set Location = Map(LocationKey)
Else
Set Location = Application.Workbooks.Add(xlWBATWorksheet)
Map.Add LocationKey, Location
End If
SalesKey = Source.Cells(Row, 5).Value2
' get the sheet for the salesperson
Set Sales = GetSheet(SalesKey, Location)
' Get the location to enter the data
InsertPos = Sales.Range("A1").End(xlDown).Row + 1
'check to see if it's a new sheet, and adjust
If InsertPos = 1048577 Then
'Stop
InsertPos = 2
'change to 65537 is using excel 2003 or before
Macro1
End If
' populate said row with the data from the source
Dim i As Long
For i = 1 To 2
Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i)
Next i
For i = 3 To 14
Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i + 2)
Next i
For i = 19 To 20
Sales.Cells(InsertPos, i).Value2 = Source.Cells(Row, i - 2)
Next i
Sales.Range("L" & InsertPos).Formula = "=(F2*K2)+F2"
Sales.Range("N" & InsertPos).Formula = "=(M2+H2)*L2"
'increment the loop
'Range("H" & InsertPos).Activate
'If Range("F" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (100 * Range("G" & InsertPos) / Range("F" & InsertPos))
'Range("I" & InsertPos).Activate
'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("F" & InsertPos) / Range("S" & InsertPos) - 1)
'Range("J" & InsertPos).Activate
'If Range("S" & InsertPos) = 0 Then ActiveCell.Value = 0 Else If 1 = 1 Then ActiveCell.Formula = (Range("T" & InsertPos) / Range("S" & InsertPos))
Row = Row + 1
Macro2 'runs on each cell
Loop
' loop over the resulting workbooks and save them - using the location name as file name
For Each Index In Map.Keys
Set Location = Map(Index)
Location.SaveAs Filename:=Index
Next Index
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
' get a named worksheet from specified workbook, creating it if required
Public Function GetSheet(ByVal Name As String, ByVal Book As Workbook, Optional ByVal Ignore As Boolean = False) As Worksheet
Dim Sheet As Worksheet
Dim Key As String
Dim Result As Worksheet: Set Result = Nothing
Key = UCase(Name)
' loop over all the worksheets
For Each Sheet In Book.Worksheets
' break out of the loop if the sheet is found
If UCase(Sheet.Name) = Key Then
Set Result = Sheet
Exit For
End If
Next Sheet
' if the sheet isn't found..
If Result Is Nothing Then
If Ignore = False Then
If Not GetSheet("Sheet1", Book, True) Is Nothing Then
' rename sheet1
Set Result = Book.Worksheets("Sheet1")
Result.Name = Name
End If
Else
' create a new sheet
Set Result = Book.Worksheets.Add
Result.Name = Name
End If
Dim arr
arr = Array("Rank", "Customer Segment", "Salesrep Name", "Main_Customer_NK", "Customer", "FY13 Inv Cost GP$", "FY13 Inv Cost GP%", "Sales Growth", "GP Point Change", "Sales % Increase", _
"Budgeted Total Sales", "Budget GP%", "Budget GP$", "Target Account", "Estimated Total Purchases", "Estimated Sales Calls Monthly", "Notes", "Reference 1", "Reference 2")
Dim i As Long
For i = LBound(arr) To UBound(arr)
Result.Cells(1, i + 1) = arr(i)
Next i
' stick the rest in the arr variable and you dont need the below anymore
'Result.Cells(1, 1) = "Rank"
'Result.Cells(1, 2) = "Customer Segment"
'Result.Cells(1, 3) = "Salesrep Name"
'Result.Cells(1, 4) = "Main_Customer_NK"
'Result.Cells(1, 5) = "Customer"
'Result.Cells(1, 6) = "FY13 Sales"
'Result.Cells(1, 7) = "FY13 Inv Cost GP$"
'Result.Cells(1, 8) = "FY13 Inv Cost GP%"
'Result.Cells(1, 9) = "Sales Growth"
'Result.Cells(1, 10) = "GP Point Change"
'Result.Cells(1, 11) = "Sales % Increase"
'Result.Cells(1, 12) = "Budgeted Total Sales"
'Result.Cells(1, 13) = "Budget GP%"
'Result.Cells(1, 14) = "Budget GP$"
'Result.Cells(1, 15) = "Target Account"
'Result.Cells(1, 16) = "Estimated Total Purchases"
'Result.Cells(1, 17) = "Estimated Sales Calls Monthly"
'Result.Cells(1, 18) = "Notes"
'Result.Cells(1, 19) = "Reference 1"
'Result.Cells(1, 20) = "Reference 2"
'and the rest....
End If
Set GetSheet = Result
End Function
Sub Macro1()
' avoid using Select
Columns.AutoFit
Columns("F:G").NumberFormat = "$#,##0.00"
Columns("H:J").NumberFormat = "0.0%"
Range("K:K,M:M").NumberFormat = "0.0%"
Range("N:N,L:L").NumberFormat = "$#,##0.00"
Columns("S:T").EntireColumn.Hidden = True
With Range("K:K,M:M").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Cells.Select
'Range("L9").Activate
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Cells.Select
'Cells.EntireColumn.AutoFit
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
'14), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub
Sub Macro2()
Columns.AutoFit
'Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(6, 7, 12, _
14, 20), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End Sub