I'm building a worksheet of qualified persons which search the each range in row (each row is a person, columns are different qualifications), to find out if the the range is empty, if not, the name of the person will be added into the list.
The question is why rng = Worksheets("Q Matrix").Range(Cells(i, 5), Cells(i, 8)) is not taken by the program and reported as error 1004?
Private Sub CommandButton1_Click()
Dim rng As Range
Dim lastr As Long, lastr1 As Long
Dim i As Integer
Application.ScreenUpdating = False
lastr = Worksheets("Auditorenliste").Range("B" & Rows.Count).End(xlUp).Row + 1
lastr1 = Worksheets("Q Matrix").Range("B" & Rows.Count).End(xlUp).Row + 1
For i = 6 To lastr1
rng = Worksheets("Q Matrix").Range(Cells(i, 5), Cells(i, 8)) 'range("E" & i & ":G" & i)
If WorksheetFunction.CountA(rng) > 0 Then
Worksheets("Auditorenliste").Cells(lastr1, 2).Value = Worksheets("Q Matrix").Cells(i, 2).Value
End If
Next
Application.ScreenUpdating = True
End Sub
You need to use the Set keyword to set the value of an object variable.:
set rng = Worksheets("Q Matrix").Range(Cells(i, 5), Cells(i, 8))
Related
I am in the process of automating a day to day process. I have ID's in column F and ID2's in column G. How could I write a VBA for filling in the blanks if the IDs in column F are the same? IE ID 123 will always have the ID of 1. In some cases the ID to be used is not the one from above.
Test data:
ID ID2
123 1
123 *Blank*
456 56
456 *Blank*
456 *Blank*
789 23
I have utilized some existing stackoverflow code and tried to adapt it for my needs.
Code:
Sub FindingtheBID()
Dim sht As Worksheet, lastrow As Long, i As Long, j As Long
Set sht = ThisWorkbook.Worksheets("Roots data")
lastrow = sht.Cells(sht.Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow
If Range("G" & i).Value = "" Then
For j = 1 To lastrow
If Range("C" & i).Value = Range("F" & j).Value And Range("G" &
j).Value <> "" Then
Range("H" & i).Value = Range("G" & j).Value
Exit For
End If
Next j
End If
Next i
End Sub
Something like as follows? I need to do a quick syntax check on other machine.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Roots data")
lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("F1:G" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If Not IsEmpty(dataArr(currentRow, 2)) And Not dict.exists(dataArr(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 2)) Then
dataArr(currentRow, 2) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("F1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
I want to find a range of same values in column A , and then calculate it average , can anyone help me ? below the code :
https://i.stack.imgur.com/bU1hW.png
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
Columns("A:A").Select
Set cell = sELECTION.Find(What:="i", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If cell Is Nothing Then
'do it something
Else
'do it another thing
End If
End Sub
Thanks !
Solution 1
Try this
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
See image for reference.
Solution 2
Another easier approach will be to use formula. Enter the following formula in Cell E2
=AVERAGEIF($A$2:$A$11,D2,$B$2:$B$11)
Drag/Copy down as required. Change range as per your data.
For details on AVERAGEIF see this.
EDIT : 1
Sub test()
Dim sht As Worksheet
Dim inputLR As Long, outputLR As Long
Dim cel As Range, aRng As Range, bRng As Range
Dim dict As Object, c As Variant, i As Long
Set dict = CreateObject("Scripting.Dictionary")
Set sht = ThisWorkbook.Worksheets("Sheet1") 'your data sheet
With sht
inputLR = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row in column A
Set aRng = .Range(.Cells(2, 1), .Cells(inputLR, 1)) 'data range in column A
Set bRng = .Range(.Cells(2, 2), .Cells(inputLR, 2)) 'data range in column B
c = aRng
For i = 1 To UBound(c, 1)
dict(c(i, 1)) = 1
Next i
.Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys) 'display uniques from column A
outputLR = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row in column D
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
End With
End Sub
EDIT : 2 To get Min, instead of
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1) = Application.WorksheetFunction.AverageIf(aRng, cel, bRng) 'calculate average
Next cel
use
For Each cel In .Range(.Cells(2, 4), .Cells(outputLR, 4)) 'loop through each cell in Column D
cel.Offset(0, 1).FormulaArray = "=MIN(IF(" & aRng.Address & "=" & cel.Value & "," & bRng.Address & "))"
Next cel
.Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value = .Range(.Cells(2, 4), .Cells(outputLR, 4)).Offset(0, 1).Value
Use WorksheetFunction.AverageIf function, see code below :
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim Rng As Range
Dim Avg1 As Double, Avg2 As Double
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Rng = .Range("A1:A" & LastRow)
' average of values in column B of all cells in column A = 1
Avg1 = WorksheetFunction.AverageIf(Rng, "1", .Range("B1:B" & LastRow))
' average of values in column B of all cells in column A = 2
Avg2 = WorksheetFunction.AverageIf(Rng, "2", .Range("B1:B" & LastRow))
End With
End Sub
This is using a variant array method. Try this.
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Dim vDB, vR(), rngDB, vResult()
Dim r As Integer, n As Long, j As Long, i As Integer
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
rngDB = .Range("a1", "b" & LastRow)
vDB = .Range("d2", .Range("d" & Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vResult(1 To r)
For i = 1 To r
n = 0
For j = 1 To LastRow
If vDB(i, 1) = rngDB(j, 1) Then
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = rngDB(j, 2)
End If
Next j
vResult(i) = WorksheetFunction.Average(vR)
Next i
.Range("e2").Resize(r) = WorksheetFunction.Transpose(vResult)
End With
End Sub
To use the .Find Function
Find the values in column A excluding duplicates
Use the unique values on the Find Function
When the value is found, sum the value in column B and on a counter
Divide the sum value by the counter to obtain the average value
Dim ws As Worksheet
Dim rng As Range, rngloop As Range, cellFound As Range, c As Range
Set ws = ThisWorkbook.Sheets(1)
lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(lastrow, 1))
For i = 2 To lastrow
Set c = ws.Cells(i, 1)
Set rngloop = ws.Range(ws.Cells(2, 1), ws.Cells(i, 1))
x = Application.WorksheetFunction.CountIf(rngloop, c)
If x = 1 Then
'Debug.Print c 'Values in column A without duplicates
'Work with the values found
With rng
Set cellFound = .Find(what:=c, LookIn:=xlValues, MatchCase:=False)
If Not cellFound Is Nothing Then
FirstAddress = cellFound.Address
Do
SumValues = ws.Cells(cellFound.Row, 2) + SumValues
k = k + 1
Set cellFound = .FindNext(cellFound)
Loop While Not cellFound Is Nothing And cellFound.Address <> FirstAddress
AverageValues = SumValues / k
Debug.Print "Value: " & c & " Average: " & AverageValues
End If
End With
End If
k = 0
SumValues = 0
Next i
Note that the use of .Find is slower than CreateObject("Scripting.Dictionary"), so for large Spreadsheets the code of #Mrig is optimized
Please try this code:
Sub test()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i)) > 1 Then
'if found more than one value
'do it another thing
sht.Range("B" & i) = Application.WorksheetFunction.SumIf(sht.Range("A1:A" & LastRow), _
sht.Range("A" & i)) / Application.WorksheetFunction.CountIf(sht.Range("A1:A" & LastRow), sht.Range("A" & i))
Else
'do it another thing
End If
Next i
End Sub
Hope this help.
I need assistance in creating a macro that helps me insert a value in a new column i have created
For example i have 3 countries, Belgium(BGD), Switzerland(BHS) and England(ENG) in column B. And if the value in column B is BGD, the new column should insert a value of 8261 and for switzerland, its 8159.
This is what i have tried.
Thanks.
Sub Entities()
Dim Found As Range
Dim LR As Long
Dim ws As Worksheet
Dim rng As Range
Dim Lrow As Long
Dim cell As Range
Set ws = Sheets("Europe")
Set Found = Rows(1).Find(what:="Total Amount in Foreign Currency", LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then Exit Sub
LR = Cells(Rows.Count, Found.Column).End(xlUp).Row
Found.Offset(, 1).EntireColumn.Insert
Cells(1, Found.Column + 1).Value = "Entities"
Set rng = Range("B2:B127")
Select Case rng
Case "BGD"
Range(Cells(2, Found.Column + 1), Cells(LR, Found.Column + 1)).Value = 8261
Case "BHS"
Range(Cells(2, Found.Column + 1), Cells(LR, Found.Column + 1)).Value = 8159
Case "ENG"
Range(Cells(2, Found.Column + 1), Cells(LR, Found.Column + 1)).Value = 8550
End Select
End Sub
Sub Entities()
Dim Found As Range
Dim LR As Long
Dim ws As Worksheet
Dim cell As Range
Dim a As Variant, v As Variant
Set ws = Sheets("Europe")
Set Found = ws.Rows(1).Find(what:="Total Amount in Foreign Currency", _
LookIn:=xlValues, lookat:=xlWhole)
If Found Is Nothing Then Exit Sub
a = [{"BGD",8261;"BHS",8159;"ENG",8550}] 'create 2-d lookup array
LR = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
Found.Offset(0, 1).EntireColumn.Insert
ws.Cells(1, Found.Column + 1).Value = "Entities"
For Each cell In ws.Range(ws.Range("B2"), ws.Cells(LR, 2))
v = Application.VLookup(cell.Value, a, 2, False)
cell.EntireRow.Cells(Found.Column + 1).Value = IIf(IsError(v), "", v)
Next cell
End Sub
Maybe a for loop will work for you
Dim i as Integer
i=2
For i=2 to i=127
If Instr(1,ActiveSheet.Range("B" & i & "").Value>0,"BGD") Then
ActiveSheet.Range("C" & i & "").Value = "8261"
End If
If Instr(1,ActiveSheet.Range("B" & i & "").Value>0,"BHS") Then
ActiveSheet.Range("C" & i & "").Value = "8159"
End If
If Instr(1,ActiveSheet.Range("B" & i & "").Value>0,"ENG") Then
ActiveSheet.Range("C" & i & "").Value = "8550"
End If
Next i
I've been trying to create a macro that extracts specific cell data from several open workbooks that all contain a specific sheet named ("Report_Final")
Currently, my macro goes sth like this:
Sub PerLineItem()
'Main function i'm trying to call for each open workbook
Dim wb As Workbook
Dim ws, ws2 As Worksheet
Dim i, j, k, x, rng As Integer
Dim temp_total As Double
Dim mat_name1, mat_name2 As String
i = 2
j = 2
k = 2
rng = 0
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Sheets.Add
Set ws = ActiveSheet
'Intermediate sheet to filter only columns 2, 11 & 18'
ws.Name = "Report"
Cells(1, 2) = "WBS"
Cells(1, 3) = "Material"
Cells(1, 4) = "Sell Total Price"
Sheets("zero250").Select
Do While Cells(i, 2) <> ""
rng = rng + 1
i = i + 1
Loop
'Copy and paste columns 2, 11, 18 to 2, 3, 4 in the new sheet("Report")
Do While j < rng
If ((Right(Cells(j, 2), 3) = "RTN") Or (Right(Cells(j, 2), 3) = "NRT")) Then
Union(Cells(j, 2), Cells(j, 11), Cells(j, 18)).Copy
Sheets("Report").Select
Union(Cells(k, 2), Cells(k, 3), Cells(k, 3)).Select
ActiveSheet.Paste
Sheets("zero250").Select
k = k + 1
End If
j = j + 1
Loop
'Create new sheet to group up identical named materials and sum the value up
Sheets.Add
Set ws2 = ActiveSheet
'The debugger always points to the below line "name is already taken" since it is being run in the same workbook
ws2.Name = "Report_Final"
Sheets("Report").Select
i = 2
j = 2
k = 2
x = 2
rng = 1
Do While Cells(i, 2) <> ""
rng = rng + 1
i = i + 1
Loop
'deletes identicals names and sums the value up, puts the values onto sheet("Report_final")
Do While j <= rng
If Cells(j, 3) <> "" Then
mat_name1 = Cells(j, 3).Value
temp_total = Cells(j, 4).Value
For x = j To rng
mat_name2 = Cells(x + 1, 3).Value
If mat_name2 = mat_name1 Then
temp_total = temp_total + Cells(x + 1, 4).Value
Rows(x + 1).ClearContents
End If
Next x
Sheets("Report_Final").Select
Cells(k, 2) = mat_name1
Cells(k, 3) = temp_total
Sheets("Report").Select
Rows(j).ClearContents
k = k + 1
j = j + 1
Else
j = j + 1
End If
Loop
'Labels the new columns in "Report_Final" and calculates the grand total
ws2.Select
Cells(1, 1).Value = wb.Name
Cells(1, 2).Value = "Material"
Cells(1, 3).Value = "Sell Total Price"
Cells(k, 3).Value = Application.Sum(Range(Cells(2, 3), Cells(k, 3)))
Application.DisplayAlerts = False
'Deletes intermediate sheet "Report"
Sheets("Report").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
In my Main function where I use:
For each wb in Workbooks
PerLineItem
Next wb
It doesn't call PerLineItem for each of the open workbooks but instead trys to perform the function again on the same workbook.
P.S I know there may be a easier way to write all this code but I do not know prior knowledge to VBA :(
Edit : Hi so I've used your code with a little modification and it works fine! But now when i add this next part, it only works through the last workbook, as the counter k does not seem to loop for the earlier workbooks
'~~> cleaning up the sheet still goes here
With wb.Sheets("Report")
rng2 = .Range("B" & .Rows.Count).End(xlUp).Row
MsgBox rng2
Do While j <= rng2
If Cells(j, 3) <> "" Then
mat_name1 = .Cells(j, 3).Value
temp_total = .Cells(j, 4).Value
For x = j To rng2
mat_name2 = .Cells(x + 1, 3).Value
If mat_name2 = mat_name1 Then
temp_total = temp_total + .Cells(x + 1, 4).Value
.Rows(x + 1).ClearContents
End If
Next x
.Rows(j).ClearContents
.Cells(k, 2) = mat_name1
.Cells(k, 3) = temp_total
k = k + 1
j = j + 1
Else
j = j + 1
End If
Loop
MsgBox k
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
P.S I've decided to scrap creating another worksheet and work within "Report"
Try this:
Dim wb As Workbook
For Each wb in Workbooks
If wb.Name <> Thisworkbook.Name Then
PerLineItem wb
End If
Next
Edit1: You need to adapt your sub like this
Private Sub PerLineItem(wb As Workbook)
Dim ws As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, k As Long, x As Long, rng As Long
Dim temp_total As Double
Dim mat_name1 As string, mat_name2 As String
i = 2: j = 2: k = 2: rng = 0
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'~~> Improve initializing ws
Set ws = wb.Sheets.Add(wb.Sheets(1))
ws.Name = "Report"
'~~> Directly work on your object; You can also use the commented lines
With ws
.Cells(1, 2) = "WBS" '.Range("B1") = "WBS"
.Cells(1, 3) = "Material" '.Range("C1") = "Material"
.Cells(1, 4) = "Sell Total Price" '.Range("D1") = "Sell Total Price"
End With
'~~> Same with the other worksheet
With wb.Sheets("zero250")
rng = .Range("B" & .Rows.Count).End(xlUp).Row
.AutoFilterMode = False
.Range("B1:B" & rng).AutoFilter 1, "=*RTN*", xlOr, "=*NRT*"
.Range("B1:B" & rng).Offset(1,0).SpecialCells(xlCellTypeVisisble).Copy _
ws.Range("B" & ws.Rows.Count).End(xlup).Offset(1,0)
End With
'~~> cleaning up the sheet still goes here
End Sub
Above code is the equivalent of your code up to generating the Report Sheet only.
Can you continue? :) I run out of time. ;p
Btw, hope this helps.