Option Explicit
Sub ActivityMatching()
Dim wsToLook As Worksheet
Set wsToLook = ThisWorkbook.Sheets("DataOra")
Dim rngToLook As Range
Set rngToLook = wsToLook.Range("A2:H1000")
Dim wsMain As Worksheet
Set wsMain = ThisWorkbook.Sheets("Sheet2")
Dim iCell As Range
Dim rngToInsert As Range
Dim lastRow As Long
Dim whatToFind As Variant
With wsMain
.Range("A1:M1").AutoFilter Field:=1, Criteria1:="Dialer Attempt"
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rngToInsert = .Range("K2:K" & lastRow).SpecialCells(xlCellTypeVisible)
For Each iCell In rngToInsert
whatToFind = iCell.Offset(, -10).Value
iCell.Value = Application.VLOOKUP(CLng(whatToFind), rngToLook, 7, False)
Next iCell
End With
End Sub
Sheet "Sheet2" column A- the key, column K where I want to put the values
Sheet "DataOra" column A the key, column G the values.
enter image description here
I received 2042 error. All the values are #N/A
enter image description here
Related
I'm trying to make a SUMIF using VBA to sum the values until the end of the column, always changing the criteria of the sum using the previus cell of the previous column as parameter.
Sub SOMA()
Dim r As Range
For Each r In Range("E1")
r = ("E1" + 1)
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("F1:F" & LastRow) = WorksheetFunction.SumIfs(Range("A:A"), Range("B:B"), Range(r))
Next r
End Sub
the r should always change to E1,E2,E3,etc. until end of the column. Because the E is always a new criteria.
Edit 1:
Sorry for my bad explaning, what i expected was make a SUMIF(A:A;E1;B:B) row by row placing the values on column F always changing the criteria to E2,E3,E4,etc. until the end of the column F.
VBA SumIfs
Option Explicit
Sub SOMA()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Source
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Range("B" & sws.Rows.Count).End(xlUp).Row
Dim scrg As Range: Set scrg = sws.Range("B2:B" & slRow) ' Criteria Range
Dim ssrg As Range: Set ssrg = sws.Range("A2:A" & slRow) ' Sum Range
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1")
Dim dlRow As Long: dlRow = dws.Range("E" & dws.Rows.Count).End(xlUp).Row
Dim dcrg As Range: Set dcrg = dws.Range("E2:E" & dlRow) ' Criteria Range
Dim dsrg As Range: Set dsrg = dws.Range("F2:F" & dlRow) ' Sum Range
Dim dcOffset As Long: dcOffset = dsrg.Column - dcrg.Column
Application.ScreenUpdating = False
Dim dcCell As Range ' Criteria Cell
' Loop.
For Each dcCell In dcrg.Cells
dcCell.Offset(, dcOffset).Value = Application.SumIfs(ssrg, scrg, dcCell)
Next dcCell
Application.ScreenUpdating = True
MsgBox "Soma is done.", vbInformation
End Sub
I think you want multiple SUMIFS in column F where column E has the criteria. If so you don't need a loop, you can just enter the formula in F1 and use FILLDOWN to complete the rest
Sub SOMA()
Dim LastRow as Long
LastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("F1") = WorksheetFunction.SumIfs(Range("A:A"), Range("B:B"), Range("E1"))
Range("F1:F"&LastRow).FillDown
End Sub
From what’s in your code I’m assuming:
column E is being SUMIF’d
column A is the range being assessed for the SUMIF
column B is providing the criteria for the SUMIF
the SUMIF value is being output to column F
This is how I’d do it…
Sub Soma()
Dim wf As WorksheetFunction
Dim r_A As Range, r_B As Range, r_E As Range, r_F As Range
Set wf = Application.WorksheetFunction
For i = 0 To ActiveSheet.Range("E1048576").End(xlUp).Row - 1
Set r_A = Range(Range("A1"), Range("A1").Offset(i, 0))
Set r_B = Range("B1").Offset(i, 0)
Set r_E = Range(Range("E1"), Range("E1").Offset(i, 0))
Set r_F = Range("F1").Offset(i, 0)
r_F = wf.SumIf(r_A, r_B, r_E)
Next
End Sub
I have a worksheet with sales data, I've managed to create Autofilter based on department and copied the results into the new sheet (Output). What I'm trying to achieve is that code will multiply the results of respective month by value in "Adjustment" row.
So the result is following
Is there a way how to process calculations within my code or I shall multiply each column in different Sub afterwards?
Dim Last_Row As Long
Dim DbExtract, DuplicateRecords As Worksheet
Dim WKS2 As Worksheet
Dim rn As Range
Set DbExtract = ThisWorkbook.Sheets("Data")
Set DuplicateRecords = ThisWorkbook.Sheets("Output")
Set WKS2 = ThisWorkbook.Sheets("Dashboard")
iMultiplier = WKS2.Range("Z18")
Application.ScreenUpdating = False
Last_Row = DuplicateRecords.Range("A" & Rows.Count).End(xlUp).Row + 1
DbExtract.Range("C3:R1500").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A" & Last_Row).PasteSpecial
DuplicateRecords.Range("$A$1:$P$400").AutoFilter Field:=3, Criteria1:=WKS2.Range("V2")
Set rn = DuplicateRecords.Range("G2:G500").SpecialCells(xlCellTypeVisible)
For Each cell In rn
iNewnumber = cell * iMultiplier
Next cell
End Sub
Here's an example:
Sub Tester()
Dim lastRow As Long, wb As Workbook
Dim wsData As Worksheet, wsOutput As Worksheet
Dim wsDash As Worksheet, rngVis As Range, numVisRows As Long
Dim rn As Range, rngAdj As Range, m As Long, adj, c As Range
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data") 'consistent naming helps...
Set wsOutput = wb.Sheets("Output")
Set wsDash = wb.Sheets("Dashboard")
'iMultiplier = wsDash.Range("Z18") '?
Application.ScreenUpdating = False
Set rngVis = wsData.Range("C3:R1500").SpecialCells(xlCellTypeVisible)
numVisRows = rngVis.Cells.Count / rngVis.Columns.Count
rngVis.Copy
lastRow = wsOutput.Range("A" & Rows.Count).End(xlUp).Row + 1 'start of pasted data
wsOutput.Range("A" & lastRow).PasteSpecial
Set rngAdj = wsDash.Range("C5:N5") 'for example
For m = 1 To rngAdj.Columns.Count 'loop the cells in the adjustments range
adj = rngAdj.Cells(m).Value 'adjustment value
If Len(adj) > 0 And IsNumeric(adj) Then 'have an adjustment to make?
'loop the relevant cells in the pasted data
For Each c In wsOutput.Cells(lastRow, "A").Offset(0, 2 + m).Resize(numVisRows).Cells
If Len(c.Value) > 0 And IsNumeric(c.Value) Then 'any thing to adjust?
c.Value = c.Value * adj
End If
Next c
End If
Next m
End Sub
Hi I previously posted about some difficulties in running a loop. I made some adjustments to it. I am wondering what is wrong.
Sub Macro1()
Dim DVariable As Date
Dim RngFind As Range
Dim MonthNo, YearNo As Integer
Dim StartDate, EndDate As Date
Dim PasteCell As Range
Dim M As Long, i As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Application.DisplayAlerts = False
Sheets("By Trader").Select
Set ws1 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "NEW"
Set ws = Sheets("Macro")
Sheets("Macro").Select
M = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For M = 2 To M
With Sheets("By Trader")
'loop column N until last cell with value (not entire column)
For Each Cell In .Range("N1:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
If Cell.Value = M Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets("NEW").Rows(Cell.Row)
End If
Next M
Application.DisplayAlerts = True
End Sub
I am aiming to extract the entire row if there is a match in values to another sheet.
You are missing a Next Cell and an End With
Sub Macro1()
Dim DVariable As Date
Dim RngFind As Range
' You need to declare every variable in the line. If you don't it will be declared as a variant instead of just your last declaration
Dim MonthNo As Integer, YearNo As Integer
Dim StartDate, EndDate As Date
Dim PasteCell As Range
Dim M As Long, i As Long, NoRow As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Application.DisplayAlerts = False
Sheets("By Trader").Select
Set ws1 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "NEW"
Set ws = Sheets("Macro")
ws.Select
' Changed variable to prevent erroneous errors
NoRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For M = 2 To NoRow
With Sheets("By Trader")
'loop column N until last cell with value (not entire column)
For Each Cell In .Range("N1:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
If Cell.Value = M Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets("NEW").Rows(Cell.Row)
End If
' Missing the next two lines
Next Cell
End With
Next M
Application.DisplayAlerts = True
End Sub
Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
'Find Last column in current row
LastCol = 1 'wks.Cells(rrow, wks.Columns.Count).End(xlToLeft).Column
Set colRange = wks.Range(wks.Cells(rrow, 1), wks.Cells(rrow, LastCol)) <-------------- I get a Run-time error 1004 Application defined or object defined error.
'Loop through all cells in row up to last col
For Each cell In colRange
'Do something to each cell
Debug.Print (cell.Value)
Next cell
Next rrow
ScreenUpdating = True
End Sub
I get an Application-defined or object-defined error. The code looks okay but not sure why its not working here.
I am trying to get all the used cells in Column A
Option Explicit
Sub iterateThroughAll()
Application.ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range, rrow As Range
Dim colRange As Range, Cell As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
'Find Last column in current row
LastCol = 1 'wks.Cells(rrow, wks.Columns.Count).End(xlToLeft).Column
Set colRange = wks.Range(wks.Cells(rrow.Row, 1), wks.Cells(rrow.Row, LastCol))
'Loop through all cells in row up to last col
For Each Cell In colRange
'Do something to each cell
Debug.Print (Cell.Value)
Next Cell
Next rrow
Application.ScreenUpdating = True
End Sub
I am trying to populate a range of cells dynamically using VLookup. My Active Sheet is where I am trying to insert value of cells from another worksheet in same workbook. For the second parameter of VLookup I am trying to use the variable dataRng which gets me the entire range of values to lookup in my source sheet (srcSheet). All the code works as expected except the VLookup returns #NAME? and its the dataRng variable which seems to be the issue. Any suggestions?
Sub VlookUpCreateDate()
Dim srcSheetName As String
Dim currSheetName As String
Dim currlastRow As Long
Dim currlastCol As Long
Dim srcLastRow As Long
Dim srcLastCol As Long
Dim srcFirstRow As Long
Dim srcSheet As Worksheet
Dim firstVar As String
Dim refRng As Range, ref As Range, dataRng As Range
srcSheetName = ActiveWorkbook.Worksheets(1).Name
Set srcSheet = ActiveWorkbook.Sheets(srcSheetName)
'Get Last Row and Column
With ActiveSheet
currlastRow = ActiveSheet.UsedRange.Rows.Count
currlastCol = ActiveSheet.UsedRange.Columns.Count
End With
With srcSheet
srcFirstRow = 2
srcLastRow = srcSheet.UsedRange.Rows.Count
srcLastCol = srcSheet.UsedRange.Columns.Count
End With
Set dataRng = srcSheet.Range(srcSheet.Cells(srcFirstRow, srcLastCol), srcSheet.Cells(srcLastRow, srcLastCol))
For i = 2 To currlastRow
Cells(i, currlastCol + 1).Select
ConvertToLetter & "$" & srcLastRow
ActiveCell.Formula = "=VLOOKUP(A2,dataRng,4,False)"
Next i
End Sub
Here is a simple example that should work for you, using the dataRng address in the formula
Dim dataRng As Range, s
Set dataRng = Range("AA1:AF7")
s = dataRng.Address
ActiveCell = "=VLOOKUP(A2," & s & ",4,0)"