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?
Related
I'm stuck in an assignment for school, this is what i have to do:
This is the current code I have:
You need to loop in the array you've loaded and :
Sub Ratio()
Dim OperatingRatio() As Double
Dim j As Long
With Sheets("Summary")
OperatingRatio = .Cells("I80:M80").Value
For j = LBound(OperatingRatio, 2) To UBound(OperatingRatio, 2)
If OperatingRatio(1, j) > 100 Then
MsgBox .Cells(14, 9 + j)
.Cells(80, 9 + j).Interior.Color = vbRed
Else
End If
Next j
End With
End Sub
It is better if you loop through all cells individually, like this:
Dim i As Integer
'9 means column I and 13 is column M
For i = 9 To 13
' Getting the percent values
Debug.Print Worksheets("Summary").Cells(80, i).Value
Next
This way you can continue by yourself.
I have an issue with my VBA code. I try to go through a whole table that has a lot of data. I go through a first column with a first condition required. Once this condition is complete, I go through the column next to the first one but starting at the same position I stopped the previous one. Once the second condition is complete, I try to do a copy paste. But for some reasons I got the error "Subscript out of Range" Could you please help me?
Here is the code:
Sub Match()
Dim i As Integer
i = 0
Dim j As Integer
Do
i = i + 1
Loop Until Sheets("Sheet1").Range("A1").Offset(i, 0).Text = Sheets("Sheet2").Range("I5").Text
j = i
Do
j = j + 1
Loop Until Sheets("Sheet1").Range("B1").Offset(j, 0).Value = Sheets("Sheet2").Range("I11").Value
Sheets("Sheet1").Range("C1").Offset(j, 0).Copy
Sheets("Sheet2").Range("N11").Paste
End Sub
Thanks guys
This should do the same thing without any loops:
Sub Match()
Dim lastA As Long, lastB As Long
Dim i As Long, j As Long
With Sheets("Sheet1")
last a = .Cells(.Rows.count, 1).End(xlUp).Row
last b = .Cells(.Rows.count, 2).End(xlUp).Row
End With
i = WorksheetFunction.Match(Sheets("Sheet2").Range("I5").Text, Sheets("Sheet1").Range("A:A"), 0)
j = WorksheetFunction.Match(Sheets("Sheet2").Range("I11").value, Sheets("Sheet1").Range("B" & i & ":B" & lastB), 0)
Sheets("Sheet2").Range("N11").value = Sheets("Sheet1").Cells(j, 3).value
End Sub
I didn't get the same error as you but I changed the last line and it seems to work.
Sub Match()
Dim i As Integer
i = 0
Dim j As Integer
Do
i = i + 1
Loop Until Sheets("Sheet1").Range("A1").Offset(i, 0).Text = Sheets("Sheet2").Range("I5").Text
j = i
Do
j = j + 1
Loop Until Sheets("Sheet1").Range("B1").Offset(j, 0).Value = Sheets("Sheet2").Range("I11").Value
Sheets("Sheet1").Range("C1").Offset(j, 0).Copy Destination:=Sheets("Sheet2").Range("N11")
End Sub
I did notice that your code runs for ever if you do not get a match which is not good. You may want to add a solution to this. It can be as easy as adding
Or i > 10000 on the Loop Until lines.
I modified your code slightly:
Sub Match()
Dim i As Integer
i = 0
Dim j As Integer
Do
i = i + 1
Loop Until Sheets("Sheet1").Range("A1").Offset(i, 0).Text = Sheets("Sheet2").Range("I5").Text
j = i
Do
j = j + 1
Loop Until Sheets("Sheet1").Range("B1").Offset(j, 0).Value = Sheets("Sheet2").Range("I11").Value
Sheets("Sheet1").Range("C1").Offset(j, 0).Copy Sheets("Sheet2").Range("N11")
End Sub
and it worked fine with data like:
In Sheet1.
Note the B match must be below the A match.
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..
here's what my macro does. It finds a string given a large excel file and goes to that column. At that point, it finds a user inputted string and copies all results onto the column next to it. I started learning VBA yesterday, so any help is appreciated.
here's where it gets the error
While InStr(UCase(Worksheets("Sheet1").Cells(1, j)), UCase("request")) = 0
Here's my complete macro so far.
Sub FineMe()
Dim i, j As Long
Dim count, test As Integer
userinput = InputBox("Enter String", Search, "Collect user input")
Cells.Interior.ColorIndex = 28
While InStr(UCase(Worksheets("Sheet1").Cells(1, j)), UCase("request")) = 0
j = j + 1
Wend
EndRow = Worksheets("Sheet1").Cells(Rows.count, j).End(xlUp).Row
count = 1
For i = 1 To EndRow
test = InStr(UCase(Cells(i, j)), UCase(userinput))
If test > 0 Then
Cells(count, j + 1).Value = Cells(i, j).Value
count = count + 1
End If
Next i
End Sub
Any help would be appreciated. THANKS!
Just add j = 1 before While, because after declaration Dim i, j As Long we have j equals to 0 and Worksheets("Sheet1").Cells(1, 0) triggers an error (we haven't Cells(1,0))
Sub FineMe()
Dim i, j As Long
Dim count, test As Integer
userinput = InputBox("Enter String", Search, "Collect user input")
Cells.Interior.ColorIndex = 28
j = 1
While InStr(UCase(Worksheets("Sheet1").Cells(1, j)), UCase("request")) = 0
j = j + 1
Wend
EndRow = Worksheets("Sheet1").Cells(Rows.count, j).End(xlUp).Row
count = 1
For i = 1 To EndRow
test = InStr(UCase(Cells(i, j)), UCase(userinput))
If test > 0 Then
Cells(count, j + 1).Value = Cells(i, j).Value
count = count + 1
End If
Next i
End Sub
BTW, in line Dim i, j As Long only j is Long, but i is Variant. You should use Dim i As Long, j As Long instead. The same thing with Dim count, test As Integer - you should declare it as follows: Dim count As Integer, test As Integer
i think Instr(1, what you wrote.
clic Instr in VB editor, and press F1
Sub Add_sumf()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
For Each y In bb.Range("A:A")
On Error GoTo Label
If UCase(bb.Cells(j, "A").Value) <> "" Then
cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), aa.Range("B:B"), UCase(bb.Cells(1, k).Value), aa.Range("G:G"), UCase(bb.Cells(j, "A").Value))
bb.Cells(j, k).Value = TimeValue(cellDate1)
cellDate1 = TimeValue("00:00:00")
bb.Cells(j, k).NumberFormat = "[h]:mm:ss"
On Error GoTo Label
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
I am using above code to add time duration based upon value of two other columns but I always get 00:00:00 as result.
if i use below code i get the answer but its too slow very slow
Sub add_it_time()
Dim i As Integer
i = 3
Dim cellDate As Integer
cellDate = 0
Dim cellDate1 As Date
cellDate1 = TimeValue("00:00:00")
Dim total As Integer
total = 0
Dim j As Integer
j = 2
Dim k As Integer
k = 2
Set aa = Workbooks("Book3").Worksheets(1)
Set bb = Workbooks("Final_result").Worksheets(1)
Do While bb.Cells(1, k).Value <> ""
'MsgBox bb.Cells(1, k).Value
For Each y In bb.Range("A:A")
On Error GoTo Label
' MsgBox UCase(bb.Cells(j, "A").Value)
If UCase(bb.Cells(j, "A").Value) <> "" Then
For Each x In aa.Range("F:F")
On Error Resume Next
If UCase(aa.Cells(i, "B").Value) = UCase(bb.Cells(j, "A").Value) Then
' MsgBox aa.Cells(i, "F").Text
' total = total + Int(get_Second(aa.Cells(i, "F").Text))
If UCase(aa.Cells(i, "G").Value) = UCase(bb.Cells(1, k).Value) Then
'MsgBox aa.Cells(i, "F").Text
cellDate1 = cellDate1 + TimeValue(aa.Cells(i, "F").Value)
End If
End If
i = i + 1
Next
i = 3
On Error GoTo Label
bb.Cells(j, k).NumberFormat = "h:mm:ss"
bb.Cells(j, k).Value = WorksheetFunction.Text(cellDate1, "[hh]:mm:ss")
total = 0
cellDate1 = 0
j = j + 1
Else
Exit For
End If
Next
j = 2
k = k + 1
Loop
Label:
'MsgBox Err.Description
Exit Sub
End Sub
The source column which contains date is of general formatt
I am new to VBA macros
UPDATED SOLUTION:
After discussion in chat with OP it was decided that pure formula solution is fine - below are formulas / actions to do on the separate sheet starting A1:
Row A will be resulting table header: in A1 I added Agent Name / Release Code, and starting B1 there's a list of all available Release Code values (easily got using Remove Duplicates).
I defined the following named ranges for the simplicity and effectiveness (since initial data is NOT static): AgentNames=OFFSET('Agent State'!$B$2,0,0,COUNTA('Agent State'!$B:$B)-1,1) - this will return the range of names on the initial sheet excluding the header; TimeInStateData=OFFSET(AgentNames,0,4) and ReleaseCodes=OFFSET(AgentNames,0,5) as shifted AgentNames range.
In column A we should obtain the list of names, which should be unique, so select in column A any number of cells which is NOT less that number of unique names - for the sample I used A2:A51, and type that formula: =IFERROR(INDEX(AgentNames,SMALL(IF(MATCH(AgentNames,AgentNames,0)=ROW(INDIRECT("1:"&ROWS(AgentNames))),MATCH(AgentNames,AgentNames,0),""),ROW(INDIRECT("1:"&ROWS(AgentNames))))),"") and press CTRL+SHIFT+ENTER instead of usual ENTER - this will define a Multicell ARRAY formula and will result in curly {} brackets around it (but do NOT type them manually!).
B2: =IF(OR($A2="",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))=0),"",SUMPRODUCT(--($A2=AgentNames),--(B$1=ReleaseCodes),TIMEVALUE(TimeInStateData))) - normal formula, which will return empty value for either empty name or zero time.
Copy formula from B2 to the whole table.
Remarks:
Resulting range for the sum of time values should be formatted as Time.
If the list of names should be expanded in the future - repeat step 3 for the new range, but do NOT drag the formula down - this will result in You cannot change part of an array error.
Sample file: https://www.dropbox.com/s/quudyx1v2fup6sh/AgentsTimeSUM.xls
INITIAL ANSWER:
Perhaps that's too simple and obvious, but at a glance I don't understand why you have that line of code:
cellDate1 = TimeValue("00:00:00")
right after your SUMIFS: cellDate1 = WorksheetFunction.SumIfs(aa.Range("F:F"), ...
Try to remove the first one where you assign zeros to cellDate1.