I'm working with this code which Will help me to go over a group of columns depending on the date.
The thing is, I'm trying to make my file to check the frecuency of the values and count the values that "Cumplen".
I mean, if the values in cells(x,"c") are "Diarios" then count the quantity of "Cumple" in cells(x,"w").
I'm using offset function cuz it allows me to go over more than one column at a time.
Thanks.
Sub pruebaestadisticas()
Application.ScreenUpdating = True
Set r = ThisWorkbook.Sheets("Seguimiento").Rows(2).Cells
fila = ThisWorkbook.Sheets("Seguimiento").Range("A" & Rows.count).End(xlUp).Row
With ThisWorkbook.Sheets("Seguimiento")
For x = 4 To fila
For Each c In r
If c.Value = "3/1/2022" Then
If .Cells(x, "C").Value = "Diario" Then
c.Offset(fila - 1, 1).Value = WorksheetFunction.CountIf(.Range(c.Offset(x - 2, 1), c.Offset(x - 2, 1)), "Cumple")
End If
End If
Next c
Next x
End With
End Sub
This is the same code in a direct way:
Sub pruebaestadisticas2()
Application.ScreenUpdating = True
Set r = ThisWorkbook.Sheets("Seguimiento").Rows(2).Cells
fila = ThisWorkbook.Sheets("Seguimiento").Range("A" & Rows.count).End(xlUp).Row
ThisWorkbook.Sheets("Seguimiento").Range("W33").Value = ""
With ThisWorkbook.Sheets("Seguimiento")
For x = 4 To fila
For Each c In r
If c.Value = "3/1/2022" Then
If .Cells(x, "C").Value = "Diario" Then
.Range("W33").Value = WorksheetFunction.CountIf(.Cells(x, "W"), "Cumple")
End If
End If
Next c
Next x
End With
End Sub
Related
I'm trying to clean up raw data exported from an online database.
There can be up to five columns. If all cells in a row have a value of 0, I want to delete that row.
When the user exports the data, they can choose to exclude columns, and the columns can be in any order.
For example, if the data contains only two of the possible five columns, I want to check just those two for 0s.
Could do a a big loop looking at every row and seeing if all 5 columns in that row are blank
Sub test()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("sheetname")
Dim LastRow As Integer
LastRow = sh.UsedRange.Rows.Count - 1
For i = 1 To LastRow
If (sh.Cells(i, 1).Value = "" And sh.Cells(i, 2).Value = "" And sh.Cells(i, 3).Value = "" And _
sh.Cells(i, 4).Value = "" And sh.Cells(i, 5).Value = "") Then
sh.Cells(i, 1).EntireRow.Delete
i = i - 1
Dim newLastRow As Integer
newLastRow = sh.UsedRange.Rows.Count - 1
If i = newLastRow Then
Exit For
End If
End If
Next i
MsgBox ("Done")
End Sub
#kyle campbell, thank you for your input! It didn't quite get me there, but it did get my wheels turning. Here is the solution I came up with, if anyone's curious:
I set a variable to represent the column number for each of the 5 possible columns using Range.Find. If the Find came up with nothing, I set the variable to 49, since the maximum number of columns this report can have is 48.
Then I did a nested If to test if the value in each cell was either 0 or null (because if the column number is 49, there won't be any data there). If all Ifs were true, I deleted the row. I also added a counter and message box, just to make sure this worked.
Sub DeleteRows()
Dim O As Long
Dim E As Long
Dim H As Long
Dim B As Long
Dim P As Long
lRow = Range("A1").CurrentRegion.Rows.Count
If Range("1:1").Find("SUM(OBLIGATIONS)") Is Nothing Then
O = 49
Else
O = Range("1:1").Find("SUM(OBLIGATIONS)").Column
End If
If Range("1:1").Find("SUM(EXPENDITURES)") Is Nothing Then
E = 49
Else
E = Range("1:1").Find("SUM(EXPENDITURES)").Column
End If
If Range("1:1").Find("SUM(HOURS)") Is Nothing Then
H = 49
Else
H = Range("1:1").Find("SUM(HOURS)").Column
End If
If Range("1:1").Find("SUM(BUDGET_RESOURCES)") Is Nothing Then
B = 49
Else
B = Range("1:1").Find("SUM(BUDGET_RESOURCES)").Column
End If
If Range("1:1").Find("SUM(PRIOR_YEAR_RECOVERY)") Is Nothing Then
P = 49
Else
P = Range("1:1").Find("SUM(PRIOR_YEAR_RECOVERY)").Column
End If
Dim j As Integer
j = 0
For i = lRow To 2 Step -1
If Cells(i, O) = 0 Or Cells(i, O) = "" Then
If Cells(i, E) = 0 Or Cells(i, E) = "" Then
If Cells(i, H) = 0 Or Cells(i, H) = "" Then
If Cells(i, B) = 0 Or Cells(i, B) = "" Then
If Cells(i, P) = 0 Or Cells(i, P) = "" Then
Rows(i).Delete
j = j + 1
End If
End If
End If
End If
End If
Next i
MsgBox "Macro complete, " & j & " lines deleted."
End Sub
I have a column with certain values which are also the headers for some columns. I want to check where the column values match and paste the value from the first column into the column with the same column name. I have around 1200 values in the first column. I want to loop through those values and paste the matching values in the corresponding row.
[![Data][1]][1]
Here is my sheet with my data that I want to work on. How I want my final sheet to look like is as follows:
Weeks | W1 | W2 | W3 | W4 | W5 | W6
W1 W1
W3 W3
Any help for the same would be highly appreciated.
Sub Weeks()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Mas As Worksheet
Set Mas = Sheets("Master Sheet")
For i = 5 To 1200
If Mas.Range("B" & i) <> "" Then
If Mas.Range("AO" & i) = "Missing week" Then
Mas.Range("AV" & i) = ""
Mas.Range("AW" & i) = ""
Mas.Range("AX" & i) = ""
Mas.Range("AY" & i) = ""
Mas.Range("AZ" & i) = ""
Mas.Range("BA" & i) = ""
Else
For j = 5 To 1200
If Mas.Range("AO" & i) = "W1" Then
Mas.Range("AV" & j) = "W1"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W2" Then
Mas.Range("AW" & j) = "W2"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W3" Then
Mas.Range("AX" & j) = "W3"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W4" Then
Mas.Range("AY" & j) = "W4"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W5" Then
Mas.Range("AZ" & j) = "W5"
GoTo Nexti
ElseIf Mas.Range("AO" & i) = "W6" Then
Mas.Range("BA" & j) = "W6"
GoTo Nexti
End If
Next j
End If
End If
Nexti:
Next i
End Sub
This is the code I tried so far but it does not show any output.
This is how you use the dictionary to achieve your goal:
Option Explicit
Sub Weeks()
Dim Mas As Worksheet: Set Mas = ThisWorkbook.Sheets("Master Sheet")
With Mas
'Calculate thelast row
Dim i As Long
Dim LastRow As Long: LastRow .Cells(.Rows.Count, "AO").End(xlUp).Row
'insert your data into an array
Dim arr As Variant: arr = .Range("AO5:BA" & LastRow).Value
'Generate a dictionary with the headers
'this needs the library Microsoft Scripting Runtime under Tools->References
Dim Headers As Dictionary: Set Headers = LoadHeaders(.Range("AO4:BA4").Value)
'Now loop through the array
For i = 1 To UBound(arr)
If Headers.Exists(arr(i, 1)) Then arr(i, Headers(arr(i, 1))) = arr(i, 1)
arr(i, 1) = vbNullString
Next i
.Range("AO5:BA" & LastRow).Value = arr
End With
End Sub
Private Function LoadHeaders(arr As Variant) As Dictionary
Set LoadHeaders = New Dictionary
Dim i As Long
For i = 1 To UBound(arr, 2)
LoadHeaders.Add arr(1, i), i
Next i
End Function
You won't even need the Application.ScreenUpdating because it does only one operation in Excel, will take a second or two to end this procedure.
Place this code in a module and link it to a button on the sheet.
'data
Cells.Clear
wks = Array("W1", "W2", "W3", "W4", "W5", "W6", "Missing week")
For i = 1 To 30
Cells(i, 2) = wks(Int(Rnd * 7))
Next i
'code
Set weeks = [b:b]
For Each wk In weeks
If Len(wk) = 2 Then Cells(wk.Row, Right(wk, 1) + 2) = wk
Next wk
weeks contains the column that has the list of column headings. The For..Each statement loops through each entry in this list.
Then it checks each entries string length. If it is length 2, it assumes the entry is valid (i.e of the form 'Wx' with x between 1 and 6), and then uses the inbuilt Right function to find the value of x, and then adds the appropriate entry into the appropriate column.
I have Excel Database which i just want to input only the tag number and i will automatic display the result in textbox... but in takes 30sec to display the result
Private Sub cmdSearch_Click()
Dim x As Long
Dim y As Long
x = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row
For y = 1 To x
If Sheets("Clients").Cells(y, 1).Text = TextBox1.Value Then
TextBox1.Text = Sheets("Clients").Cells(y, 1)
TextBox4.Text = Sheets("Clients").Cells(y, 3)
TextBox5.Text = Sheets("Clients").Cells(y, 4)
TextBox10.Text = Sheets("Clients").Cells(y, 5)
TextBox11.Text = Sheets("Clients").Cells(y, 6)
TextBox12.Text = Sheets("Clients").Cells(y, 7)
TextBox13.Text = Sheets("Clients").Cells(y, 8)
End If
Next y
End Sub
Match is pretty fast
Private Sub cmdSearch_Click()
Dim m As VARIANT
With Sheets("Clients")
m = Application.Match(TextBox1.Value, .Columns(1), 0)
If not iserror(m) then
TextBox4.Text = .Cells(m, 3)
TextBox4.Text = .Cells(m, 4)
'etc
end if
end with
End Sub
Looping through 60,000 rows of data will be slow. Why don't you try Range.Find() instead? The documentation is here https://learn.microsoft.com/en-us/office/vba/api/excel.range.find
A sample code from that page is
With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End With
In your code you could do something like the following. Declare a range variable and set it to the result of the find command. From the found range you can offset to the desired columns to retrieve their values.
dim result as range
x = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row
set result = Sheets("Clients").Range("A1:A" & x).Find(TextBox1.Value, lookin:=xlValues)
if not result is nothing then
TextBox1.Text = result.value
TextBox4.Text = result.offset(0,2).value
' and so on. use offset to get results from other columns in the row where the found range is
end if
I search any text within Worksheet2 and display the results in ListBox1.
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
'Populating listbox from search
Dim i As Long
For i = 2 To Sheet2.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(Sheet2.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
Sheet2.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
I want to search multiple worksheets instead but don't know how to achieve this without changing the code completely.
You're going to have to change the reference to Sheet2 if you want to look at multiple sheets. There's no way around that. But, it will make your code more flexible. Start by doing this:
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
Dim ws As Worksheet 'This is the new line of code where you define your worksheet
Set ws = ActiveWorkbook.Sheet2 'Replace all references below to Sheet2 with this
'Populating listbox from search
Dim i As Long
For i = 2 To ws.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(ws.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
ws.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
Now that you're generalized your Sub, you can modify the value of ws to repeat the code as much as you need to. If it is every sheet in your workbook, you can use a For Each loop, like
For Each ws In ActiveWorkbook
'All your code for the ws here
Next ws
Or, you can define the worksheets in an array beforehand.
Dim SheetList(0 to 2) As String
Dim k As Integer
SheetList(0) = "Sheet 2 Name"
SheetList(1) = "Sheet 4 Name"
SheetList(2) = "Sheet 3 Name"
SheetList(3) = "Sheet 6 Name"
For k = LBound(SheetList) To UBound(SheetList)
ws = ActiveWorkbook.Sheets(SheetList(k))
'The rest of your code from above
Next k
You didn't specify in your question what kind of sheets how many, or how they are organized. But, these options should be enough to get you where you are trying to go.
Could someone help me out with the following code, I thought i figured it out but keep on stranding with the same problem:
Sub history()
nsheets = ActiveWorkbook.Worksheets.Count 'count sheets in workbook
nas_index = ActiveSheet.Index 'index of the activated sheet
nas_LR = Sheets(nas_index).Cells(Sheets(nas_index).Rows.Count, "A").End(xlUp).Row 'count rows of activesheet
For d = 1 To nsheets
If d < nas_index Then
pre_index = Sheets(nas_index - d).Index
pre_LR = Sheets(pre_index).Cells(Sheets(pre_index).Rows.Count, "A").End(xlUp).Row
oldtime = Sheets(d).Cells(1, 6).Value
newwknr = Sheets(nas_index).Cells(1, 7).Value
oldwknr = Sheets(pre_index).Cells(1, 7).Value
StrOldTime = Format(oldtime, "hh:mm:ss")
For n = 3 To nas_LR
prid_new = Sheets(nas_index).Cells(n, 1).Value
For o = 3 To pre_LR
prid_old = Sheets(pre_index).Cells(o, 1).Value
pre_am = Sheets(pre_index).Cells(o, 6).Value
pre_amw = CStr(pre_am) & "(" & StrOldTime & ")" & "(wk: " & oldwknr & ")"
If prid_new = prid_old Then
'Below is not working properly
'------------------------------
re = re & " " & pre_amw
Sheets(nas_index).Cells(n, 10).Value = re
'------------------------------
End If
Next o
Next n
Else
'MsgBox exit loop
Exit For
End If
Next d
'------------------nevermind below
Dim ntime As Date, nStrTime As String
If Not ThisWorkbook.ActiveSheet.Cells(1, 10).Value = "" Then
'-new time
ThisWorkbook.ActiveSheet.Cells(1, 12).Value = Time()
ntime = ThisWorkbook.ActiveSheet.Cells(1, 12).Value
mstrtime = Format(ntime, "hh:mm:ss:ms")
ThisWorkbook.ActiveSheet.Cells(1, 12).Value = mstrtime
'-old time
gettime = ThisWorkbook.ActiveSheet.Cells(1, 10).Value
ThisWorkbook.ActiveSheet.Cells(1, 11).Value = gettime
myStrTime = Format(gettime, "hh:mm:ss:ms")
ThisWorkbook.ActiveSheet.Cells(1, 11).Value = myStrTime
End If
End Sub
The image below is so far what I got (the text in red, is what i wish to have).
My goal is to have the following Check if I bought the same item before (ID). Collect data of this ID and store it in the column History. So that I can see if the product has been price changed over the previous weeks. I can't get the data properly of previous sheets. Instead of getting the following:
item: A B C D or
item: D C B A
I get something like this:
item: A A A A A A B B B B B B C C C C C C D D D D D D or
item: A B C D A B C D A B C D
I think I am failing here:
If prid_new = prid_old Then
'Below is not working properly
'------------------------------
re = re & " " & pre_amw
Sheets(nas_index).Cells(n, 10).Value = re
'------------------------------
End If
Can someone lent me a hand.
I tried looping the worksheets within a grocery item loop with some success.
Historical data is gathered from every worksheet prior to the current worksheet (ActiveSheet) onto the current worksheet.
Option Explicit
Sub costHistory()
Dim i As Long, w As Long, gro As Long, ndx As Long, g As Variant
Dim icost As Double, lcost As Double, dif As String
With ActiveSheet
ndx = ActiveSheet.Index
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
gro = .Cells(i, "A").Value2
lcost = .Cells(i, "D").Value2
dif = vbNullString
For w = 1 To ndx - 1
With Worksheets(w)
g = Application.Match(gro, .Columns(1), 0)
If Not IsError(g) Then
If .Cells(g, "D").Value2 <> lcost Then
dif = Format(.Cells(g, "D").Value2, "0.00") & _
Format(.Cells(g, "F").Value2, " 0 ") & _
Format(.Cells(1, "F").Value2, "(hh:mm:ss)") & _
Format(.Cells(1, "G").Value2, " (\w\k\:0)") & _
Chr(124) & dif
End If
End If
End With
Next w
If CBool(Len(dif)) Then
.Cells(i, "J") = Left(dif, Len(dif) - 1)
End If
Next i
End With
End Sub