Good day to all,
I keep getting the same runtime error while executing my code. I don't have formal training in VBA (mostly some VB in highschool).
The code is this
Sub Lavaggi2():
Dim i, j, k, lavaggio, x, daymax As Integer
Dim day As Date
Dim Ore(10) As Single
Dim column_len, row_len As Integer
Dim totale_ore As Integer
'Determining variable for row and columns
column_len = Sheets("Foglio7").Cells.CurrentRegion.Columns.Count
row_len = Sheets("Foglio7").Cells.CurrentRegion.Rows.Count
k = 1
For j = 1 To row_len
For i = 1 To column_len
If (Sheets("Foglio7").Cells(2, i).Value = "Codice") Then
If (Sheets("Foglio7").Cells(j, i).Value = "00/100" Or Sheets("Foglio7").Cells(j, i).Value = "00/200") Then
day = Sheets("Foglio7").Cells(j, 1).Value
For k = 1 To 10
If (Sheets("Foglio7").Cells(j - k, 1).Value = day) Then
Ore(k) = Sheets("Foglio7").Cells(j - k, i + 5).Value
daymax = daymax + 1
Else
End If
Next k
totale_ore = Worksheet.funcion.Sum(Ore)
lavaggio = Sheets("Foglio7").Cells(j, i + 7) / totale_ore
For x = 1 To daymax
Sheets("Foglio7").Cells(j - x, i + 7).Value = lavaggio * Ore(x)
Next x
Erase Ore
End If
End If
Next i
Next j
End Sub
The line where I get the error is
If (Sheets("Foglio7").Cells(j - k, 1).Value = day) Then
I'm quite sure it's something silly but I'm unable to wrap my head around it.
PS: I'm aware that the code is probably a little clunky but I'll streamline it at a future stage.
Thanks to all who will answer
On your first iteration of the loop, j - k would equal 0, and your cell would be .Cells(0, 1), which doesn't exist.
I managed to solve the issues I encountered. It works as intended. Thanks to all for the help
Sub Lavaggi2():
Dim i, j, k, x, daymax As Integer
Dim day As Date
Dim lavaggio, totale_ore, Ore(10) As Double
Dim column_len, row_len As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
column_len = Sheets("Foglio7").Cells.CurrentRegion.Columns.Count
row_len = Sheets("Foglio7").Cells.CurrentRegion.Rows.Count
daymax = 1
For j = 1 To row_len
For i = 1 To column_len
If (Sheets("Foglio7").Cells(2, i).Value = "Codice") Then
If (Sheets("Foglio7").Cells(j, i).Value = "00/100" Or Sheets("Foglio7").Cells(j, i).Value = "00/200") Then
day = Sheets("Foglio7").Cells(j, 1).Value
For k = 1 To 10
If (Sheets("Foglio7").Cells(j - k, 1).Value = day) Then
Ore(k) = Sheets("Foglio7").Cells(j - k, i + 5).Value
daymax = daymax + 1
Else
Exit For
End If
Next k
totale_ore = Application.WorksheetFunction.Sum(Ore)
lavaggio = Sheets("Foglio7").Cells(j, i + 7) / totale_ore
For x = 1 To daymax - 1
Sheets("Foglio7").Cells(j - x, i + 7).Value = lavaggio * Ore(x)
Next x
daymax = 1
Erase Ore
End If
End If
Next i
Next j
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I also tweaked the declarations in order to achieve the desired precision in the final results.
Related
so I am getting errors for some reason "next without for"
here is the code:
Sub test()
Dim y As Integer
y = 0
For i = 1 To 7
For j = 1 To 7
If Cells(i, 1) = Cells(j, 1) Then
y = y + 1
Next j
Cells(i, 2).Value = y
y = 0
Next i
End Sub
The problem doesn't come from your For ... To ... Next but from your If condition that you forgot to close with the End If instruction.
Sub test()
Dim y As Integer
y = 0
For i = 1 To 7
For j = 1 To 7
If Cells(i, 1) = Cells(j, 1) Then
y = y + 1
End If 'You forgot to end the condition
Next j
Cells(i, 2).Value = y
y = 0
Next i
End Sub
Why do I get "Subscript out of range" on my line T(k) = Cells(k + 1, 4).Value - z?
Public Sub find()
Dim i, j, k, h As Integer
Dim T() As Double
Dim z As Double
Range("E1").Activate
i = ActiveCell.Row
j = ActiveCell.Column
While Not IsEmpty(Cells(i, j - 2).Value)
z = Cells(i, j - 2).Value
k = 0
While Not IsEmpty(Cells(k + 1, 4).Value)
T(k) = Cells(k + 1, 4).Value - z
k = k + 1
Wend
For h = 0 To k
If T(h) = Application.WorksheetFunction.Min(Abs(T(k))) Then
Cells(i, j).Value = Cells(h + 1, 4).Value
End If
Next
i = i + 1
Wend
End Sub
At the point where you say T(k) = ..., your array T hasn't been allocated yet. There isn't any such thing as T(0) yet. Hence the "Subscript out of range" error.
Before indexing into T, you have to give T a size using ReDim. For example:
Dim T() As Double
ReDim T(0 to 123) ' or whatever size you need
Sub Off_Hours_Set_TEST()
Dim x As String
Dim found As Boolean
Dim i As Integer, j As Integer
' Select first line of data.
Range("A1").Select
' Set search variable value.
x = "Off"
For i = 0 To 2
For j = 0 To 10
If ActiveCell.Value = x Then
found = True
ActiveCell.Offset(i, j + 2) = "0"
Else
ActiveCell.Offset(i, j + 2).Value = ActiveCell.Offset(i, j + 1).Value - ActiveCell.Offset(i, j).Value
End If
j = j + 2
Next j
Next i
End Sub
Trying to make a little code that tallies up hours worked for day. It works until it encounters the cell with the word 'Off' in it, then it RTE 13's on me. I'm not quiet sure why it does this, or where the mismatch is coming from, as all it is doing is checking to see if the cell = Off, if it does, it inputs a 0 in the offset hours worked column. Ideas?
I have a Macro being run on a worksheet every minute. It copies and pastes data from another worksheet and updates an existing chart.
There is a command button provided which can change the range of x & y series on that chart.
When user clicks on the command button, a userform is shown for user entry of minimum and maximum range.
But as the macro is running every second, userform focus is lost during the macro run and user has to select the user form every time. Its very annoying.
The macro does not select/activate any cell/chart on the worksheet.
How do I stop User form losing it's focus and keep it active in spite of any program running at back end?
this is the code that runs every second. 'Limits' is the user form name.
Sub doitagain()
If Len(Dir(path1 + "\mon")) <> 0 Then
If Limits.Visible Then
Limits.rangecb1.SetFocus
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Interactive = False
fromcopy = path1 + "\mon"
tocopy = path + "\mon.csv"
On Error Resume Next
FileCopy fromcopy, tocopy
filepath = path + "\mon.csv"
Set wtarget = Workbooks.Open(filepath)
wtarget.Windows(1).Visible = False
curiteration = m - 2
i = ii + 1
n = 1
Do While wtarget.Worksheets("mon").Cells(i, 2).Value <> curiteration
i = i + 1
n = n + 1
If n > ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 6).Value Then
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Interactive = True
Workbooks("mon.csv").Close savechanges = False
GoTo abc
End If
Loop
j = i
Do While wtarget.Worksheets("mon").Cells(j, 1).Value <> ""
j = j + 1
Loop
j = j - 1
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 1).Value = wtarget.Worksheets("mon").Cells(k, 2).Value
mi = mi + 1
Next
lastcol = 1
Do While wtarget.Worksheets("mon").Cells(i, lastcol).Value <> ""
lastcol = lastcol + 1
Loop
lastcol = lastcol - 1
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 4).Value = wtarget.Worksheets("mon").Cells(k, lastcol - noofsubsdoagain).Value
mi = mi + 1
Next
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 3).Value = wtarget.Worksheets("mon").Cells(k, lastcol - 1 - noofsubsdoagain).Value
mi = mi + 1
Next
mi = m
For k = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 2).Value = wtarget.Worksheets("mon").Cells(k, lastcol - 2 - noofsubsdoagain).Value
mi = mi + 1
Next
For k = 1 To noofsubsdoagain
mi = m
Dim ki As Integer
For ki = i To j
ThisWorkbook.Worksheets("Convergence_Plot").Cells(mi, 4 + k).Value = wtarget.Worksheets("mon").Cells(ki, lastcol - noofsubsdoagain + k).Value
mi = mi + 1
Next
Next
Application.Interactive = True
Set wtarget = Nothing
Workbooks("mon.csv").Close savechanges = False
mi = m
For k = i To (j - 1)
m = m + 1
Next
i = 3
Do While ThisWorkbook.Worksheets("Convergence_Plot").Cells(i, 1).Value <> ""
i = i + 1
Loop
If i > 3 Then
i = i - 1
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Interactive = True
If ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 5).Value = 1 Then
ThisWorkbook.Worksheets("Convergence_Plot").TextBox1.Value = i - 2
Else
ThisWorkbook.Worksheets("Convergence_Plot").TextBox1.Value = i - (ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 7).Value - ThisWorkbook.Worksheets("Convergence_Plot").Cells(1, 6).Value + 2)
End If
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(1).XValues = "=Convergence_Plot!$A$3:$A$" & i
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(1).Values = "=Convergence_Plot!$B$3:$B$" & i
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(2).Values = "=Convergence_Plot!$C$3:$C$" & i
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(3).Values = "=Convergence_Plot!$D$3:$D$" & i
Dim letter As String
letter = "D"
For k = 1 To 10
ThisWorkbook.Worksheets("Convergence_Plot").ChartObjects("Chart 1").Chart.FullSeriesCollection(3 + k).Values = "=Convergence_Plot!$" & Chr(Asc(letter) + k) & "$3:$" & Chr(Asc(letter) + k) & "$" & i
Next
If Limits.Visible Then
Limits.rangecb1.SetFocus
End If
End If
abc:
timetorun = Now + TimeValue("00:00:03")
Application.OnTime timetorun, "doitagain", , True
End Sub
I have a full dictionary. All the words (360 000) are in one column.
I'd like to have Column B with all words starting with "a", column C with all words starting with b...
I am trying to do a loop or something... but... It is just too long.
Any tips? Or did someone already do this vba macro?
Tks,
Stéphane.
If we start with:
Running this short macro:
Sub SeparateData()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long
N = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
End Sub
will produce:
NOTE:
You may want to add some error capture logic to the NewCol calculation line.
EDIT#1:
This version may be slightly faster:
Sub SeparateDataFaster()
Dim N As Long, i As Long, NewCol As Long
Dim M As Long, time1 As Date, time2 As Date
N = Cells(Rows.Count, 1).End(xlUp).Row
time1 = Now
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 1 To N
NewCol = Asc(UCase(Left(Cells(i, 1).Value, 1))) - 63
If Cells(1, NewCol).Value = "" Then
M = 1
Else
M = Cells(Rows.Count, NewCol).End(xlUp).Row + 1
End If
Cells(M, NewCol).Value = Cells(i, 1).Value
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
time2 = Now
MsgBox time1 & vbCrLf & time2
End Sub
You can try something like this.
For 360k records its take about 20sec.
To create tests data i use this sub:
Sub FillTestData()
Dim t As Long
Dim lng As Integer
Dim text As String
'Start = Timer
For t = 1 To 360000
text = vbNullString
lng = 5 * Rnd + 10
For i = 1 To lng
Randomize
text = text & Chr(Int((26 * Rnd) + 65))
Next i
Cells(t, 1) = text
Next t
'Debug.Print Timer - Start
End Sub
And for separate:
Sub sep()
'Start = Timer
Dim ArrWords() As Variant
Dim Row_ As Long
LastRow = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ArrWords = Range("A1:A" & LastRow) 'all data from column A to array
For i = 65 To 90 ' from A to Z
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) = i Then
Cells(Row_, i - 63) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
Next i
'other than a[A]-z[Z]
Row_ = 1
For j = LBound(ArrWords, 1) To UBound(ArrWords, 1)
If Asc(UCase(ArrWords(j, 1))) < 65 Or Asc(UCase(ArrWords(j, 1))) > 90 Then
Cells(Row_, 28) = ArrWords(j, 1)
Row_ = Row_ + 1
End If
Next j
'Debug.Print Timer - Start
End Sub
You could try:
For i = 1 To Cells(Rows.count, 1).End(xlUp).Row
Range(UCase(Left$(Cells(i, 1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Offset(IIf(Range(UCase(Left$(Cells(i, _
1).Text, 1)) & Rows.count).Offset(0, 1).End(xlUp).Row = 1, 0, 1), 0).Value = Cells(i, 1).Text
Next i
Which is just building the destination address using the first letter of the word by doing the following:
Loop through each cell in column A
Get the first letter of that cell and convert it to upper case
Find the last cell in the column starting with that letter
Move over 1 column to the right
Go up until we hit the last row of data
If the last row isn't row 1, move down another row (next blank cell)
Give this cell the same value as the cell in column A that we're assessing
You can enter the following formula:
For letter A in B Column:
=IF(UPPER(LEFT(A1,1))="A",A1,"")
For letter B in C Column:
=IF(UPPER(LEFT(A1,1))="B",A1,"")
Repeat the same for letter C, D and so on..