I am trying to find the number of colourfilled cells in B coloumn. I want to count and display the number of cour filled coloumns
But I am getting error :
Dim sum As Long
Dim count As Long
sum = 0
count = 0
strFileName = Application.GetOpenFilename("Excel files (*.xls*),*.xl*", Title:="Open data")
Set Target = Workbooks.Open(strFileName)
Set tabWS = Target.Worksheets("Tabelle1")
' lastrow = tabWS.Range("D" & tabWS.Rows.count).End(xlUp).Row 'Trigger Description starts from 2 row A coloumn
lastrow = tabWS.Range("B" & tabWS.Rows.count).End(xlUp).Row 'Trigger Description starts from 2 row A coloumn
For j = 2 To lastrow
If tabWS.Cells(j, 2).Interior.ColorIndex = 4 Then
sum = sum + tabWS.Cells(j, 8).value
count = count + 1
End If
Next j
MsgBox ("the value is" & sum)
End sub
I am getting error for sum = sum +tabs.cell(j,8).value
I can't figure it out whyI am getting this error. Can any one give me a suggestion
It looks to me like you're opening the Workbook each time you use a method on tabWS. Try setting tabWS equal to the following instead:
tabWS = Worksheets("Tabelle1")
Now when you're setting your lastrow and sum variables in the latter part of your code you won't be trying to open the workbook over and over again.
Edit (continued from comment below)*:
lastrow = Worksheets("Tabelle1").Range("B" & Worksheets("Tabelle1").Rows.count).End(xlUp).Row
For j = 2 To lastrow
If Worksheets("Tabelle1").Cells(j, 2).Interior.ColorIndex = 4 Then
sum = sum + Worksheets("Tabelle1").Cells(j, 8).value
count = count + 1
End If
Next j
MsgBox ("the value is" & sum)
End sub
Related
First time posting a question, so please correct me if I do anything I'm not supposed to!
I have a macro written on a button press to compare 2 columns on 2 sheets and output either the value from sheet 2 col 1 in sheet 1 col 6 OR output "None" in sheet1 col 6 if there isn't a match.
My code is buggy and takes a long time to run (around 5000 entry's on sheet 1 and 2000 on sheet 2).
My code works partly; it only matches around 2/3rd's of the col 1's on either sheet.
Sub Find_Sup()
Dim count As Integer
Dim loopend As Integer
Dim PartNo1 As String
Dim PartNo2 As String
Dim partRow As String
Dim SupRow As String
Dim supplier As String
Let partRow = 2
Let SupRow = 2
'Find total parts to check
Sheets("Linnworks Supplier Update").Select
Range("A1").End(xlDown).Select
loopend = Selection.row
Application.ScreenUpdating = False
'main loop
For count = 1 To loopend
jump1:
'progress bar
Application.StatusBar = "Progress: " & count & " of " & loopend & ": " & Format(count / loopend, "0%")
Let PartNo2 = Worksheets("Linnworks Supplier Update").Cells(SupRow, 1).Value
Let supplier = Worksheets("Linnworks Supplier Update").Cells(SupRow, 2).Value
If PartNo2 = "" Then
SupRow = 2
Else
jump2:
Let PartNo1 = Worksheets("Linnworks Stock").Cells(partRow, 1).Value
'add part numbers than do match
If PartNo2 = PartNo1 Then
Let Worksheets("Linnworks Stock").Cells(partRow, 5).Value = supplier
Let partRow = partRow + 1
Let count = count + 1
GoTo jump2
Else
Let SupRow = SupRow + 1
GoTo jump1
End If
End If
Next
Application.StatusBar = True
End Sub
I have done some coding in C and C++ and a little VB.NET. Any help streamlining this code or pointing me in the right direction would be very gratefully received!
I realise there are similar questions but all other options I've tried (nested for each loops) don't seem to work correctly.
This is the closest I've managed to get so far.
Many Thanks for reading
try something like this instead and leave feedback so I can edit the answer to match perfectly
Sub Main()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Linnworks Supplier Update")
Set ws2 = Sheets("Linnworks Stock")
Dim partNo2 As Range
Dim partNo1 As Range
For Each partNo2 In ws1.Range("A1:A" & ws1.Range("A" & Rows.Count).End(xlUp).Row)
For Each partNo1 In ws2.Range("A1:A" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
If StrComp(Trim(partNo2), Trim(partNo1), vbTextCompare) = 0 Then
ws2.Range("E" & partNo1.Row) = partNo2.Offset(0, 1)
ws2.Range("F" & partNo1.Row) = partNo2
End If
Next
Next
'now if no match was found then put NO MATCH in cell
for each partno1 in ws2.Range("E1:F" & ws2.Range("A" & Rows.Count).End(xlUp).Row)
if isempty(partno1) then partno1 = "no match"
next
End Sub
Consider a scenario, I have 2 columns (Column "A" & Column "B").
Column A has around 130000 rows/Strings
Column B has around 10000 rows/Strings
I would like to search each string of Column "B" from Column "A".
As you can see the volume of data is very high. I have already tried with Range.Find() method. But it's taking lot of time to complete. I am searching for a method/way that will give me result in very less turnaround time.
* Some more Clarification on my requirement *
(1) Column A & B contains string values, NOT NUMBERS. And the string can be very large
(2) For each cell in column "B", There can be many occurrence in column "A"
(3) I would like to fetch all the occurrence of column "B" in column "A" with Row Number
(4) For a string present in column "B". It can be found as a Substring of any cell in column "A"
Download file link - wikisend.com/download/431054/StackOverFlow_Sample.xlsx *
Any Suggestions ?
Feel free incase you need any extra details to solve above problem !
Try this.
This took 3 seconds for 130000 rows in Col A and 10000 rows in Col B. The output is generated in Col C.
NOTE: I have taken the worst case scenario where all 10000 values in Col B are present in Col A
This is how my data looks.
Sub Sample()
Debug.Print Now
Dim col As New Collection
Dim ws As Worksheet
Dim i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
.Range("C1:C10000").Value = "No"
For i = 1 To 130000
On Error Resume Next
col.Add .Range("A" & i).Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
On Error Resume Next
For i = 1 To 10000
col.Add .Range("B" & i).Value, CStr(.Range("B" & i).Value)
If Err.Number <> 0 Then .Range("C" & i).Value = "Yes"
Err.Clear
Next i
End With
Application.ScreenUpdating = True
Debug.Print Now
End Sub
And this was the result
NEW
Column A 130000 100-character strings, Column B 10000 30-character strings, 27 minutes.
Column C is populated with row locations of occurrences of Column B string.
Column D is populated with number of occurrences of Column B string.
Public Sub searchcells()
Dim arrA(1 To 130000) As String, arrB(1 To 10000) As String, t As Date, nLen As Integer
t = Now
Me.Range("c:d") = ""
For i = 1 To 130000
arrA(i) = Me.Cells(i, 1)
Next
For i = 1 To 10000
arrB(i) = Me.Cells(i, 2)
Next
For i = 1 To 130000
nLen = Len(arrA(i))
For j = 1 To 10000
If InStrRev(arrA(i), arrB(j), nLen - Len(arrB(j)) + 1) > 0 Then Me.Cells(j, 4) = Me.Cells(j, 4) + 1: Me.Cells(j, 3) = Me.Cells(j, 3) & i & "; "
Next
Me.Cells(1, 5) = i
Next
Debug.Print CDbl(Now - t) * 24 * 3600 & " seconds"
End Sub
The cells can be populated easily with the following, changing i and j limits for the desired number of strings and string lengths in each section.
Public Sub fillcells()
Dim temp As String
Randomize
For i = 1 To 13000
temp = ""
For j = 1 To 100
temp = temp & Chr(70 + Int(10 * Rnd()))
Next
Me.Cells(i, 1) = temp
Next
For i = 1 To 10000
temp = ""
For j = 1 To 30
temp = temp & Chr(70 + Int(10 * Rnd()))
Next
Me.Cells(i, 2) = temp
Next
End Sub
I am unable to download your spreadsheet at work, so disregard this if it missed the mark.
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.
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub
I am getting the 1004 error when running. The error is at this line:
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
What I want to do is to select the sheet (CTRYNAME) and then search through columns 5,7,9 etc and format the numbers as done in the code.
Public Sub MoM_Check()
Dim inti As Integer
Dim intj As Integer
Dim k As Integer
Dim mnth As Integer
Dim currSALE As Double
Dim prevSALE As Double
Dim diffpercent As Double
Dim CTRYname As String
Dim x As Integer
Dim column As String
'Find Difference percentage between sales of 24 common months in present month's extarct and previous month's extract
For n = 1 To 13
Application.SheetsInNewWorkbook = 4
Set wkbTemp = Workbooks.Add
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
'Open a temporary workbook to do all the Calculations
'First the current month's extract is copied to the first sheet
'We now copy sheets for range from wkbout to wkbtemp using usedrange
wkbCurr.Sheets(CTRYname).Activate
wkbCurr.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet1").Range("A1").PasteSpecial
wkbprev.Sheets(CTRYname).Activate
wkbprev.Sheets(CTRYname).UsedRange.Copy
wkbTemp.Sheets("Sheet2").Range("A1").PasteSpecial
'open the Previous month's Main Extract file as given in the lookup tab. This data is pasted on sheet2 of temporary workbook.
'This sheet helps us to compare the country channels in current month's extract with the previous Month's Extract.
'So the same process is followed for this sheet and similarly we get the country channels from the previous month's extract and paste them on 'sheet3
'Prevcnt contains the number of country channels in the previous month's extract
k = 1
For mnth = 0 To 22
currSALE = wkbTemp.Sheets("Sheet1").Range("AB10").Offset(0, mnth).Value
prevSALE = wkbTemp.Sheets("Sheet2").Range("AC10").Offset(0, mnth).Value
If prevSALE = 0 And currSALE <> 0 Then
diffpercent = 1
ElseIf prevSALE = 0 And currSALE = 0 Then
diffpercent = 0
Else: diffpercent = (currSALE - prevSALE) / prevSALE
End If
If diffpercent > 0.01 Or diffpercent < -0.01 Then
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Incorrect"
Exit For
Else
Set wkbRaw = Workbooks.Open(strOutputQCPath & "Errorlog.xlsx")
wkbRaw.Sheets("Sheet1").Activate
wkbRaw.Sheets("Sheet1").Range("A1").Offset(i, 1 + n).Value = CTRYname & " Correct"
k = k + 1
wkbRaw.SaveAs Filename:=strOutputQCPath & "Errorlog.xlsx"
wkbRaw.Close
End If
Next mnth
For x = 1 To 15
If x = 1 Or x = 2 Or x = 3 Or x = 4 Or x = 6 Or x = 9 Or x = 10 Or x = 11 Or x = 13 Then
GoTo Name
Else
If IsNumeric(wkbCurr.Sheets(CTRYname).Range(column & x).Value) = True Then
If wkbCurr.Sheets(CTRYname).Range(column & x).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Range(column & x).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Range(column & x).Value = "<-999%"
End If
End If
End If
Name:
Next x
wkbTemp.Close savechanges:=False
Set wkbTemp = Nothing
Next n
End Sub
Please help!
You haven't given the string "column" a value, which is why you're getting error 1004 on that line.