I have the below code which searches for specific text based on the Col header, like Col O, Col P etc. Instead I want to search using the respective column name in Row 1.
I have added the column name in the code comments.
Sub PassFailValidationandupdatecomments()
Dim Rng As Range, cl As Range
Dim LastRow As Long, MatchRow As Variant
With Sheets("DRG")
LastRow = .Cells(.Rows.count, "E").End(xlUp).Row '"E" - Live ASIN
Set Rng = .Range("E2:E" & LastRow) ' "E" - Live ASIN
End With
With Sheets("Latency")
For Each cl In .Range("B2:B" & .Cells(.Rows.count, "B").End(xlUp).Row) ` "B" - ASIN
MatchRow = Application.Match(cl.Value, Rng, 0)
If Not IsError(MatchRow) Then
Select Case Sheets("DRG").Range("AH" & MatchRow + 1).Value ' "AH" - Final Test Result
.Range("O" & cl.Row).Value = "Pass" '"O" - Pass/Fail
Case "Pended"
.Range("O" & cl.Row).Value = "Fail"'"O" - Pass/Fail
Case "In progress"
.Range("O" & cl.Row).Value = "In progress"'"O" - Pass/Fail End Select
If Not Sheets("DRG").Range("E" & MatchRow + 1).Value = vbNullString Then .Range("P" & cl.Row).Value = .Range("P" & cl.Row).Value & IIf(Not .Range("P" & cl.Row).Value = vbNullString, ";", "") & Sheets("DRG").Range("S" & MatchRow + 1).Value ' "E" - Live ASIN ; "P" - Comments ; "S" - App Trail
End If
Next cl
End With
Related
I have Excel with data.
I wrote a code that allows me to filter data depending on the company.
Sub testProjectMl()
Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
Dim i As Long, arrA, dictKP As Object
'Create a variable
Dim dictKS
Dim dictVT
Dim dictAK
Dim dictPP
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
firstRow = 8 'first row with data
arrA = sh.Range("A" & firstRow & ":A" & lastRow).Value 'place the range in an array for faster iteration
Set dictKP = CreateObject("Scripting.Dictionary")
Set dictKS = CreateObject("Scripting.Dictionary")
Set dictVT = CreateObject("Scripting.Dictionary")
Set dictPP = CreateObject("Scripting.Dictionary")
Set dictAK = CreateObject("Scripting.Dictionary")
With Sheets(ActiveSheet.Name)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 8 To lastRow
If IsNumeric(.Range("H" & i)) And Trim(.Range("H" & i).Value) <> "" And .Range("H" & i).Value <> 0 And .Range("H" & i).Value > 7000 Then
Select Case True
Case .Range("A" & i).Value Like "KP*"
dictKP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "KS*"
dictKS.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "VT*"
dictVT.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "PP*"
dictPP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
Case .Range("A" & i).Value Like "AK*"
dictAK.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.Cells(i + firstRow - 1, "A"), sh.Cells(i + firstRow - 1, "K")))
End Select
End If
Next i
End With
Sheets.Add.Name = "KP"
Sheets.Add.Name = "KS"
Sheets.Add.Name = "VT"
Sheets.Add.Name = "PP"
Sheets.Add.Name = "AK"
Set shDestKp = Sheets("KP")
Set shDestKs = Sheets("KS")
Set shDestVt = Sheets("VT")
Set shDestPp = Sheets("PP")
Set shDestAk = Sheets("AK")
For i = 0 To dictKP.Count - 1
lastERowDest = shDestKp.Range("A" & shDestKp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKP.items()(i).Copy shDestKp.Range("A" & lastERowDest)
shDestKp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKp.Range("K" & lastERowDest).Copy ' copy the target format
shDestKp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictKS.Count - 1
lastERowDest = shDestKs.Range("A" & shDestKs.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictKS.items()(i).Copy shDestKs.Range("A" & lastERowDest)
shDestKs.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestKs.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestKs.Range("K" & lastERowDest).Copy ' copy the target format
shDestKs.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestKs.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestKs.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictVT.Count - 1
lastERowDest = shDestVt.Range("A" & shDestVt.Rows.Count).End(xlUp).Row + 1
'If lastERowDest = 2 Then lastERowDest = 1
dictVT.items()(i).Copy shDestVt.Range("A" & lastERowDest)
shDestVt.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestVt.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestVt.Range("K" & lastERowDest).Copy ' copy the target format
shDestVt.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestVt.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestVt.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictPP.Count - 1
lastERowDest = shDestPp.Range("A" & shDestPp.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictPP.items()(i).Copy shDestPp.Range("A" & lastERowDest)
shDestPp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestPp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestPp.Range("K" & lastERowDest).Copy ' copy the target format
shDestPp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestPp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestPp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
For i = 0 To dictAK.Count - 1
lastERowDest = shDestAk.Range("A" & shDestAk.Rows.Count).End(xlUp).Row + 1
If lastERowDest = 2 Then lastERowDest = 1
dictAK.items()(i).Copy shDestAk.Range("A" & lastERowDest)
shDestAk.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
shDestAk.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
shDestAk.Range("K" & lastERowDest).Copy ' copy the target format
shDestAk.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
shDestAk.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
shDestAk.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
Application.CutCopyMode = False
Next i
End Sub
As you can see, depending on the value at the beginning of cell A, I adding the row in a certain dictionary. Then there is a cycle for each dictionary and inserting values into a specific sheets.
But I have a problem, for some reason the same line is entered in all the sheets when iterating through dictionaries.
For example (KS sheet):
This sheet should have the following value:
When Select Case and adding a row to the dictionary, the value in cell A is specified correctly and corresponds to a specific dictionary. BUT I don't understand why, when iterating through dictionaries, the same value from the dictKP dictionary is inserted.
Example what need in the end:
Please, try using the next code. It needs only a single dictionary, creating keys based on the first two company name characters. It will add new sheets based on the dictionary keys and clear the existing if they exist:
Sub testProjectMl()
Dim sh As Worksheet, newSh As Worksheet, lastRow As Long, firstRow As Long
Dim i As Long, arrA, minVal As Double, dict As Object
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
firstRow = 7 'the row where the headers exist
minVal = 7000 'you can change it (if another limit would be necessary)...
arrA = sh.Range("A" & firstRow & ":K" & lastRow).value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrA) 'iterate between the array rows:
If IsNumeric(arrA(i, 8)) And Trim(arrA(i, 8)) <> "" And arrA(i, 8) <> 0 And arrA(i, 8) > minVal Then
If Not dict.Exists(left(arrA(i, 1), 2)) Then
dict.Add left(arrA(i, 1), 2), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
Else
Set dict(left(arrA(i, 1), 2)) = Union(dict(left(arrA(i, 1), 2)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
End If
End If
Next i
'drop the dictionary items content in the appropriate sheet (add it if not existing):
Application.ScreenUpdating = False 'to make the code faster, when inserts sheet and copy ranges...
Application.EnableEvents = False
For i = 0 To dict.count - 1
If Not sheetExists(CStr(dict.Keys()(i))) Then
Set newSh = ActiveWorkbook.Sheets.Add(After:=sh) 'insert the sheet if it does not exist
newSh.name = dict.Keys()(i)
Else
Set newSh = ActiveWorkbook.Sheets(dict.Keys()(i))'set the existing sheet and clear its content
newSh.cells.ClearContents
End If
dict.items()(i).Copy newSh.Range("A1") 'copy the dictionary range
Next i
End Sub
Function sheetExists(shName As String) As Boolean
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name = shName Then sheetExists = True: Exit Function
Next ws
End Function
I'm attempting to count the number of rows in my sheet that meet 3 sets of criteria: the client name in column C matches my active row; the due date in column G; and column M is blank (indicating no previous submission was sent).
I can get this to work just fine with the following code:
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Broker Workflow")
Dim i As Long
Dim iVal As Long
Dim lastRow As Long: lastRow = ws.Range("C" & Rows.Count).End(xlUp).Row
Dim strClient As String: strClient = Cells(ActiveCell.Row, "C").Value
Dim strRenDate As String: strRenDate = Cells(ActiveCell.Row, "G").Value
Dim strNotSubmitted As String: strNotSubmitted = ""
Dim strCriteria As String: strCriteria = strClient & strRenDate & strNotSubmitted
iVal = 0
For i = 8 To lastRow
If ws.Range("C" & i).Value & ws.Range("G" & i).Value & ws.Range("M" & i).Value = strCriteria Then
iVal = iVal + 1
End If
Next i
Dim strCount As String: strCount = iVal
My problem is that now I want to extend this to count all rows with a due date that is within a range of my active row date +/- 7 days (14 day range). So if my due date is 07/06/2020 it will count the number of rows that match my client name in C, have blank cell in M and a date of anything between 01/06/2020-14/06/2020 in G.
You are making it more complicated than needed... can get rid of the four variables above, and simply test like this:
For i = 8 To lastRow
If ws.Range("C" & i).Value = Cells(ActiveCell.Row, "C").Value & _
ws.Range("M" & i).Value = "" & _
ws.Range("G" & i).Value >= DateAdd(Cells(-7, "d", ActiveCell.Row, "G").Value) & _
ws.Range("G" & i).Value <= DateAdd(Cells(7, "d", ActiveCell.Row, "G").Value) Then
iVal = iVal + 1
End If
Next i
[EDIT]
Sorry!
I have no idea what I wrote earlier.
I mixed up the parameters in DateAdd and used & instead of and
This works, tested:
For i = 8 To lastRow
If Cells(i, "C").Value = Cells(ActiveCell.Row, "C").Value And _
Cells(i, "M").Value = "" And _
Cells(i, "G").Value >= DateAdd("d", -7, Cells(ActiveCell.Row, "G").Value) And _
Cells(i, "G").Value <= DateAdd("d", 7, Cells(ActiveCell.Row, "G").Value) Then
iVal = iVal + 1
End If
Next i
It will also work with your ws.Range syntax, it was just simpler for me to test it like this with Cells
Please note that the current line also gets counted if it has an empty M column...
New to VBA, I've pieced together the below code which makes changes to certain cells based upon activity in Column.
I split the actions into modules to make it easier to follow but now this only works when the change in column is copy/pasted (the macro does not work if I type into the column instead).
Any ideas what I'm missing?
The Sheet Code
Option Explicit
'Event Macro to put formulas in A, B and D if C changes
Private Sub Worksheet_Change(ByVal Target As Range) ' Every Change on this sheet do this code
Dim lRow As Long
Dim cell As Range
Dim CKeyCells As Range
' Set SelectionColumn range
Set CKeyCells = Range("$C$3:$C$1048576")
If Not Intersect(Target, Columns(3)) Is Nothing Then 'If the Change wasn't in Column
CbuddyMacro
End If
End Sub
The Module/Macro Code
Public Sub CbuddyMacro()
Dim lRow As Long
Dim cell As Range
Dim selectedRange As Range
Set selectedRange = Application.Selection
For Each cell In selectedRange
If cell.Value <> "" Then 'If Col has something in it then do the following.
lRow = cell.Row 'Get the current row
Cells(cell.Row, "A").Formula = "=IF(ISBLANK(I" & lRow & "),"""",I" & lRow & ")"
Cells(cell.Row, "B").Formula = "=IF(ISBLANK(J" & lRow & "),"""",J" & lRow & ")"
Cells(cell.Row, "D").Formula = "=IF(ISBLANK(K" & lRow & "),"""",K" & lRow & ")"
Cells(cell.Row, "E").Formula = "=IFERROR(INDEX(Database!$E$3:$E$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),"""")"
Cells(cell.Row, "F").Formula = "=IFERROR(IF(ISBLANK(INDEX(Database!$F$3:$F$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),INDEX(Database!$P$3:$P$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),INDEX(Database!$F$3:$F$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),"""")"
Cells(cell.Row, "G").Formula = "=IFERROR(IF(ISBLANK(INDEX(Database!$G$3:$G$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),INDEX(Database!$Q$3:$Q$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),INDEX(Database!$G$3:$G$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),"""")"
Cells(cell.Row, "H").Formula = "=IF(ISBLANK(L" & lRow & "),"""",L" & lRow & ")"
Cells(cell.Row, "I").Formula = "=IFERROR(TEXT(LOOKUP(2,1/($M$" & lRow & ":$AP$" & lRow & "<>""""),$M$" & lRow & ":$AP$" & lRow & "),""DD-MMM-YY""),"""")"
Cells(cell.Row, "J").Formula = "=IFERROR(TEXT(LOOKUP(2,1/($BU$" & lRow & ":$CX$" & lRow & "<>""""),$BU$" & lRow & ":$CX$" & lRow & "),""DD-MMM-YY""),"""")"
Cells(cell.Row, "K").Formula = "=IFERROR(LOOKUP(2,1/($AQ$" & lRow & ":$BT$" & lRow & "<>""""),$AQ$" & lRow & ":$BT$" & lRow & "),"""")"
Cells(cell.Row, "L").Formula = "=IFERROR(LOOKUP(2,1/($CY$" & lRow & ":$EB$" & lRow & "<>""""),$CY$" & lRow & ":$EB$" & lRow & "),"""")"
End If
If cell.Value = "" Then 'If Col has nothing in it then do the following.
Cells(cell.Row, "A").Formula = ""
Cells(cell.Row, "B").Formula = ""
Cells(cell.Row, "D").Formula = ""
Cells(cell.Row, "E").Formula = ""
Cells(cell.Row, "F").Formula = ""
Cells(cell.Row, "G").Formula = ""
Cells(cell.Row, "H").Formula = ""
Cells(cell.Row, "I").Formula = ""
Cells(cell.Row, "J").Formula = ""
Cells(cell.Row, "K").Formula = ""
Cells(cell.Row, "L").Formula = ""
End If
Next cell
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
How can I Search for specific name header column "DATA/HORA" and adapt to macro below?
Sub Data()
Dim cell As Range
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lastRow)
If InStr(cell.Value, "-") <> 0 Then
cell.Value = RegexReplace(cell.Value, _
"(\d{4})\-(\d{2})\-(\d{2})", "$3/$2/$1")
End If
cell.NumberFormat = "dd/mm/yyyy;#"
Next
End Sub
Function RegexReplace
------
End Function
Replace:
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lastRow)
With:
Dim ColLetr As String
For i = 1 To Columns.Count
If Cells(1, i) = "DATA/HORA" Then
ColLetr = Split(Cells(1, i).Address, "$")(1)
End If
Next
lastRow = Range(ColLetr & Rows.Count).End(xlUp).Row
For Each cell In Range(ColLetr & "1:" & ColLetr & lastRow)
EDIT#1:
To address the Comments:
Dim ColLetr As String
For i = 1 To Columns.Count
If Cells(1, i) = "DATA/HORA" Then
ColLetr = Split(Cells(1, i).Address, "$")(1)
Exit For
End If
Next
If ColLetr = "" Then
MsgBox "DATA/HORA not found"
Exit Sub
End If
lastRow = Range(ColLetr & Rows.Count).End(xlUp).Row
For Each cell In Range(ColLetr & "1:" & ColLetr & lastRow)