Im a vba noobie, please help. I have 3000 rows and 40 columns.
Starting from row 5 to last row, and only look at columns 8,11,14,17,20,23,26,29,32.
I need to write a code saying that if each cells in colummns 8,11,14,17,20,23,26,29,32 and are in same row are absolutely smaller and equal to 5, then make a comment at the cell (row,40)="OK IN PROGRESS"
If one of the cell(columns 8,11,14,17,20,23,26,29,32) in each same row is absolutely bigger and equal to 5, then at the cell(row,40)=(whichever columns that is bigger than 5)&"NOT IN PROGRESS"
Also I need to rename each column's number.
8=george
11=cindy
14=jennifer
17=lucas
20=apple
23=jeff
26=may
29=kevin
32=oscar
So for instance, at the cell (row,40), if its 8 NOT IN PROGRESS, the 8 will be replaced by george.
and then next row
Here is a quick VBA solution, if that's what you need:
Sub ProcessRows()
Dim rSt As Integer, rEn As Integer, val As Integer, r As Integer
Dim cSt As Integer, cEn As Integer, c As Integer
Dim name As String, inProgressMsg As String, notInProgressMsg1 As String, notInProgressMsg2 As String
rSt = 5
rEn = 3004
val = 5
cSt = 8
cEn = 32
inProgressMsg = "OK IN PROGRESS"
notInProgressMsg2 = "NOT IN PROGRESS"
For r = rSt To rEn
notInProgressMsg1 = ""
For c = cSt To cEn Step 3
If Cells(r, c).Value > val Then
name = ReplaceNumberWithName(c)
notInProgressMsg1 = notInProgressMsg1 & name & " "
End If
Next c
If notInProgressMsg1 = "" Then
Cells(r, 40).Value = inProgressMsg
Else
Cells(r, 40).Value = notInProgressMsg1 & notInProgressMsg2
End If
Next r
End Sub
Function ReplaceNumberWithName(n As Integer) As String
ReplaceNumberWithName = "NO_NAME_FOUND"
If n = 8 Then
ReplaceNumberWithName = "george"
ElseIf n = 11 Then
ReplaceNumberWithName = "cindy"
ElseIf n = 14 Then
ReplaceNumberWithName = "jennifer"
ElseIf n = 17 Then
ReplaceNumberWithName = "lucas"
ElseIf n = 20 Then
ReplaceNumberWithName = "apple"
ElseIf n = 23 Then
ReplaceNumberWithName = "jeff"
ElseIf n = 26 Then
ReplaceNumberWithName = "may"
ElseIf n = 29 Then
ReplaceNumberWithName = "kevin"
ElseIf n = 32 Then
ReplaceNumberWithName = "oscar"
End If
End Function
Related
I am using a form that takes an item and quantity. I'm trying to create a running count that consists of the quantity (denoted as qtytxt1, qtytxt2, etc) of each item. Each item has its own quantity input field denoted with the ending number (i.e., qtytxt1 applies to item 1).
I am trying to have a cell located in (emptyRow, 27) to output the sum of the total quantity of all items inputted into the form (i.e., Item 1 qty = 2,000; Item 2 qty = 3,000; Expected Output = 5,000).
There are a total of 10 input fields for "Item/Qty," however, not all 10 fields are expected to be used. I have created a code that seems to work as I prefer, however, I would receive a sum error message when entering less than 10 items.
Dim emptyRow As Long
Dim data As Worksheet
Dim runCount As Long
Worksheets("mining history").Activate
emptyRow = WorksheetFunction.CountA(Range("i:i")) + 6
Set data = Sheets("data")
runCount = 0
If qtytxt2.Value = "" Then
qtytxt2.Value = 0
ElseIf qtytxt3.Value = "" Then
qtytxt3.Value = 0
ElseIf qtytxt4.Value = "" Then
qtytxt4.Value = 0
ElseIf qtytxt5.Value = "" Then
qtytxt5.Value = 0
ElseIf qtytxt6.Value = "" Then
qtytxt6.Value = 0
ElseIf qtytxt7.Value = "" Then
qtytxt7.Value = 0
ElseIf qtytxt8.Value = "" Then
qtytxt8.Value = 0
ElseIf qtytxt9.Value = "" Then
qtytxt9.Value = 0
ElseIf qtytxt10.Value = "" Then
qtytxt10.Value = 0
End If
If IsEmpty(Range("E:E")) Then
'Is Empty
runCount = 0
Else
' Not Empty
runCount = WorksheetFunction.Sum(qtytxt1.Value, qtytxt2.Value, qtytxt3.Value, qtytxt4.Value, qtytxt5.Value, qtytxt6.Value, qtytxt7.Value, qtytxt8.Value)
Cells(emptyRow, 27).Value = runCount
End If
You can use a loop:
Dim emptyRow As Long
Dim data As Worksheet, wsMH As Worksheet
Dim runCount As Long, n As Long, v
Set data = Sheets("data")
Set wsMH = Worksheets("mining history")
'no need to Activate...
emptyRow = wsMH.Cells(Rows.count, "I").End(xlUp).row + 1
If Application.CountA(wsMH.Range("E:E")) = 0 Then
runCount = 0
Else
'loop all the entry textboxes
For n = 1 To 10
v = Me.Controls("qtytxt" & n).Value
If Len(v) > 0 And IsNumeric(v) Then runCount = runCount + v
Next n
wsMH.Cells(emptyRow, 27).Value = runCount
End If
I suspect you need this:
If qtytxt2.Value = "" Then
qtytxt2.Value = 0
End If
If qtytxt3.Value = "" Then
qtytxt3.Value = 0
End If
etc
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'm trying to write code that extracts X consecutive numbers from text.
For example, if I want to extract 5 consecutive numbers in my text:
Cell A1: dsuad28d2hr 22222222 11111 d33d11103
Cell B2: 11111 (wanted)
I could make it work for texts with only 5 numbers but the problem is if my text contains other consecutive numbers higher than 5.
Sub ExtractNum2()
Dim Caract() As String
Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim cont As Integer
Dim goal As Integer
Dim Protocolo() As String
Dim cel As String
Dim lin As Long
lin = Range("A1", Range("A1").End(xlDown)).Rows.Count 'Repeat for each line
For z = 1 To lin
cel = Cells(z, 1)
ReDim Caract(Len(cel))
ReDim Protocolo(Len(cel))
cont = 0
For i = 1 To Len(cel)
Caract(i) = Left(Mid(cel, i), 1)
If IsNumeric(Caract(i)) Then 'Character check
cont = cont + 1
Protocolo(cont) = Caract(i)
'If Not IsNumeric(Caract(6)) And cont = 5 Then**
If cont = 5 '
Dim msg As String
For j = 1 To 5
msg = msg & Protocolo(j)
Next j
Cells(z, 2) = msg 'fills column B
msg = ""
End If
Else
cont = 0
End If
Next i
Next z 'end repeat
End Sub
I'm trying to use:
If Not IsNumeric(Caract(6)) And cont = 5 Then
But it is not working, my output is: B2: 22222 but I want 11111.
What am I missing?
EDIT
Sorry i wasnt clear. I want to extract X numbers with 6>x>4 (x=5). I dont want 22222 since it has 8 consecutive numbers and 11111 has 5 in my example.
UDF:
Function GetNum(cell)
With CreateObject("VBScript.RegExp")
.Pattern = "\b(\d{5})\b"
With .Execute(cell)
If .Count > 0 Then GetNum = .Item(0).SubMatches(0)
End With
End With
End Function
UPDATE:
If you want to return error (say, #N/A) instead of callee's default data type, you could write the following:
Function GetNum(cell)
With CreateObject("VBScript.RegExp")
.Pattern = "\b(\d{5})\b"
With .Execute(cell)
If .Count > 0 Then
GetNum = .Item(0).SubMatches(0)
Else
GetNum = CVErr(xlErrNA)
End If
End With
End With
End Function
I tried this with a Cell containing "Yjuj 525211111x5333332s5" to test whether 2 consecutive 5 characters get catch, and it worked great.
Sub Macro_Find_Five()
Dim str As String
Dim tmp As String
Dim cntr As Integer
Dim result As String
str = Sheet1.Cells(1, 1).Value
tmp = ""
cntr = 1
col = 2
result = ""
'For Loop for tracing each charater
For i = 1 To Len(str)
'Ignore first starting character
If i > 1 Then
'If the last character matches current character then
'enter the if condition
If tmp = Mid(str, i, 1) Then
'concatenate current character to a result variable
result = result + Mid(str, i, 1)
'increment the counter
cntr = cntr + 1
Else
'if the previous character does not match
'reset the cntr to 1
cntr = 1
'as well initialize the result string to "" (blank)
result = ""
End If
End If
'if cntr matches 5 i.e. 5 characters traced enter if condition
If cntr = 5 Then
'adding to next column the result found 5 characters same
Sheet1.Cells(1, col).Value = result
'increment the col (so next time it saves in next column)
col = col + 1
'initializing the variables for new search
cntr = 1
tmp = ""
result = ""
End If
'stores the last character
tmp = Mid(str, i, 1)
'if first character match concatenate.
If cntr = 1 Then
result = result + Mid(str, i, 1)
End If
Next i
End Sub
The code below extracts & format values from the range B6:E6, and then stores them in the variable. Afterwards, the routine sorts the collection of 4 variables in the ascending order. When sorted they're being put into the range L31:O31.
The problem is that if there are less than 4 variables selected, say 3, the routine will skip L31 cell, and put the rest to M31:O31. Whilst it should be input as L31:N31, and O31 - blank.
How can the code be modified to make it fulfill the data starting from L31 if less than 4 variables are in the collection?
Function ExtractKey(s As Variant) As Long
Dim v As Variant, n As Long
v = Trim(s) 'remove spaces leave only spaces between words
If v Like "*(*)" Then 'if it's SOPXX (YYYY) then
n = Len(v) 'find number of the characters
If n = 11 Then
v = Mid(v, n - 7, 7) 'find the number of SOP + year in bracket
ElseIf n = 12 Then
v = Mid(v, n - 8, 8)
End If
v = Replace(v, "(", "") 'replace the brackets with nothing
v = Replace(v, " ", "")
'SOP10 (2015) doesn't have to go first before SOP12 (2014); switch figures
If n = 11 Then
v = Right(v, 4) + Left(v, 1)
ElseIf n = 12 Then
v = Right(v, 4) + Left(v, 2)
End If
ExtractKey = CLng(v)
Else
ExtractKey = 0
End If
End Function
Sub Worksheet_Delta_Update()
Dim SourceRange As Range, TargetRange As Range
Dim i As Long, j As Long, minKey As Long, minAt As Long
Dim v As Variant
Dim C As New Collection
Set SourceRange = Worksheets("t").Range("B6:E6")
Set TargetRange = Worksheets("x").Range("L31:O31")
For i = 1 To 4
v = SourceRange.Cells(1, i).Value
C.Add Array(ExtractKey(v), v)
Next i
'transfer data
For i = 1 To 4
minAt = -1
For j = 1 To C.Count
If minAt = -1 Or C(j)(0) < minKey Then
minKey = C(j)(0)
minAt = j
End If
Next j
TargetRange.Cells(1, i).Value = C(minAt)(1)
C.Remove minAt
Next i
End Sub
You could add one variable e.g. col which will be used instead of variable i when the value is inserted into TargetRange. This variable will work the same way as the i works but it will be incremented only when the value which is inserted is not empty. HTH
'transfer data
Dim col As Integer
col = 1
For i = 1 To 4
minAt = -1
For j = 1 To C.Count
If minAt = -1 Or C(j)(0) < minKey Then
minKey = C(j)(0)
minAt = j
End If
Next j
If (C(minAt)(1) <> "") Then
TargetRange.Cells(1, col).Value = C(minAt)(1)
col = col + 1
End If
C.Remove minAt
Next i
i have 2 sheets , i want to find the same rows in 2 sheets , so i put the first row in array , and by a for next i define the first array ...then i define another array from second sheet , then i compare them .... why it doesn't work?
Sub compare()
Dim n(4) As Variant
Dim o(4) As Variant
Dim i As Integer
For i = 3 To 20 'satrha
For j = 2 To 4 'por kardan
n(j) = Sheets("guys").Cells(i, j)
Next 'por kardan
k = 3
Do 'hhhh
For Z = 2 To 4 'por dovomi
o(Z) = Sheets("p").Cells(k, Z)
Next 'por dovomi
If n(j) = o(Z) Then
Sheets("guys").Cells(i, 1) = Sheets("p").Cells(k, 2)
flag = True
Else
flag = False
k = k + 1
End If
Loop Until flag = False 'hhhhh
Next 'satrha
End Sub
Guessing from your existing code, my following code will copy the value from sheet "p" column B into sheet "guys" column A when a match is found.
Sub compare()
Dim i As Integer
Dim j As Integer
Dim l As Integer
l = Sheets("p").Range("B65535").End(xlUp).Row
Debug.Print l
For i = 3 To 20
For j = 3 To l
If Sheets("guys").Cells(i, 2).Value = Sheets("p").Cells(j, 2).Value And _
Sheets("guys").Cells(i, 3).Value = Sheets("p").Cells(j, 3).Value And _
Sheets("guys").Cells(i, 4).Value = Sheets("p").Cells(j, 4).Value Then
Sheets("guys").Cells(i, 1).Value = Sheets("p").Cells(j, 2).Value
Exit For
End If
Next
Next
End Sub
Noted that I explicitly said Value in my code. That will copy the computed value (e.g. result of a formula) instead of the "original" content.