I have id numbers on column A starts from A3 To A25. I want to check each of the column A value with the F G H I columns values. In F G H I columns where data starts from 29th-row, how do check with A column value with multiple columns values at a time?
lastrow = Range("A" & Rows.Count).End(xlUp).Row
lastrow1 = Range("F" & Rows.Count).End(xlUp).Row
For i = 3 To lastrow
For j = 30 To lastrow1
If Range("F" & j).Value = Range("A" & i).Value Or Range("G" & j).Value = Range("A" & i).Value Or Range("H" & j).Value = Range("A" & i).Value Or Range("I" & j).Value = Range("A" & i).Value Then
End if
Next j
Next i
use below code. i have tested on your query
Please test it if any problem, feel free to contact.
Function allvlookup(rng As Range, rng1 As Range)
Dim rng_r As Range
Dim str As String
For Each rng_r In rng1
If rng = rng_r Then
result = rng_r.Value
End If
Next rng_r
allvlookup = result
End Function
Related
I am trying to sum two columns, but i keep getting an error message of type mismatch. Where my error is?
Sub SumCols()
Dim ws As Worksheet
Set ws = Sheets("Recon")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Range("E" & i).Value = Range("C" & i).Value + Range("D" & i).Value
Next i
End Sub
The below might be my issue, I checked for blank cells and non were found. But I can see blank cells.
Most likely one of the values you are trying to add together is not numeric, so check to see if they are numeric and non-blank before you try adding them.
For i = 2 To LastRow
If Len(Range("C" & i).Value) > 0 And Len(Range("D" & i).Value) > 0 Then
If IsNumeric(Range("C" & i).Value) And IsNumeric(Range("D" & i).Value) Then
Range("E" & i).Value = Range("C" & i).Value + Range("D" & i).Value
End If
End If
Next i
Also, you might be better off just using a formula:
Range("E" & i).Formula = "=C" & i & "+D" & i
I am writing a macro, which will be used to consolidate data from a range of cells. I have the table with the data that I want to consolidate in sheets("1") in Range D2:J6 and the destination location is again in sheets("1") in M2:R2 (the colums M to R but they contain headers) . I have already written a part of the code below, which applies and runs for them. However, even though it doesnt say it has an error, it just wont run correctly.. I am prividing the screenshot from my excel after the macro runs ..
as you can see from the image, I want to consolidate the duplicate values in row D and print the average of the values located in columns E,F,G, H, I ,J on the same row as the consolidated values in column D. For example for the value "Gebze 6832" in column D, I want to remove it as a duplicate, make it one cell in the destination and print the average of the columns E,F,G, H, I ,J from the two rows that were consolidated next to it in the destination columns.
My code is below (UPDATE)
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = Sheets("1")
With ws
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastrow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
.Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastrow & ",$M" & i & ",E$2:E$" & lastrow & ")/" & dic(.Range("M" & i).Value)
.Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,N" & i & ","""")"
.Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,Q" & i & ","""")"
.Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),"""")"
Next i
.Range("M" & i).Value = "Grand Total"
.Range("N" & i & ":P" & i).Formula = "=AVERAGE(N2:N" & cnt + 1 & ")"
.Range("Q" & i).Formula = "=SUM(Q2:Q" & cnt + 1 & ")"
.Range("R" & i).Formula = "=AVERAGE(R2:R" & cnt + 1 & ")"
.Range("S" & i & ":T" & i).Formula = "=SUM(S2:S" & cnt + 1 & ")"
.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value
End With
Assuming your data is in range Column D to Column J starting from Row 2 and output has to be displayed from Column M to Column S from Row 2 following might be helpful.
Sub Demo()
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet
Application.ScreenUpdating = False
With ws
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastRow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":S" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
Next i
.Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value
End With
Application.ScreenUpdating = True
End Sub
This code will give following result.
I am working on this code that compares column A ( code source) and column B( code roc) and for each code source in column A it has his code regate in column C and address in column D so if A=B copy them back in E and F with their code regate in column G and their address in column H .
this the code I am using it blocks until I shut down excel and it doesn't give me the exact results if anyone can help me thank you
here is a picture of the result that i need from A and B , C and D
Sub copy_lignes()
Dim DerLigA, DerLigB As Long, i, j As Long
DerLigA = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
DerLigB = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To DerLigA
For j = 2 To DerLigB
If Sheets("sheet3").Range("A" & i) = Sheets("sheet3").Range("B" & j) Then
Sheets("sheet3").Range("A" & i).Copy Destination:=Sheets("sheet3").Range("E" & i)
Sheets("sheet3").Range("B" & i).Copy Destination:=Sheets("sheet3").Range("F" & i)
Sheets("sheet3").Range("C" & i).Copy Destination:=Sheets("sheet3").Range("G" & i)
Sheets("sheet3").Range("D" & i).Copy Destination:=Sheets("sheet3").Range("H" & i)
End If
Next j
Next i
End Sub
Try the code below, maybe this is what you meant in your post:
Sub copy_lignes()
Dim DerLigA, DerLigB As Long, i, j As Long
Dim PasteRow As Long
' optimize speed performance
Application.ScreenUpdating = False
With Sheets("Sheet3")
DerLigA = .Cells(.Rows.Count, "A").End(xlUp).Row
DerLigB = .Cells(.Rows.Count, "B").End(xlUp).Row
PasteRow = 2
For i = 2 To DerLigA
For j = 2 To DerLigB
If .Range("A" & i) = .Range("B" & j) Then
.Range("A" & i).Copy Destination:=.Range("E" & PasteRow)
.Range("B" & j & ":D" & j).Copy Destination:=.Range("F" & PasteRow)
PasteRow = PasteRow + 1
End If
Next j
Next i
End With
' restore settings
Application.ScreenUpdating = True
End Sub
It might be that you just need to tab in a few lines, so it should look like this:
Sub copy_lignes()
Dim DerLigA As Long
Dim DerLigB As Long
Dim i As Integer
Dim j As Integer
i = 2
j = 2
DerLigA = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
DerLigB = Sheets("sheet3").Range("B" & Rows.Count).End(xlUp).Row
For i To DerLigA
For j To DerLigB
If Sheets("sheet3").Range("A" & i) = Sheets("sheet3").Range("B" & j) Then
Sheets("sheet3").Range("A" & i).Copy Destination:=Sheets("sheet3").Range("E" & i)
Sheets("sheet3").Range("B" & i).Copy Destination:=Sheets("sheet3").Range("F" & i)
Sheets("sheet3").Range("C" & i).Copy Destination:=Sheets("sheet3").Range("G" & i)
Sheets("sheet3").Range("D" & i).Copy Destination:=Sheets("sheet3").Range("H" & i)
End If
Next j
Next i
End Sub
I'm trying to create a Macro that will modify contents in columns S, W and AH based on the content in AB
e.g. if AB1 = No, then S1=C-MEM, AH = N/A and W is cleared.
For some reason, I get a 'Type mismatch' error on the first line of my if statement and can't figure out why or how to fix it - even after reading other posts about similar issue.
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
**-> If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
Next i
End Sub
Thanks
You are trying to test if an error is = No.
Test for the error and skip the logic in that loop:
Sub test()
Dim lastrow As Long
Dim i As Long
lastrow = Range("AB" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Not IsError(Range("AB" & i).Value) Then
If Range("AB" & i).Value = "No" Then
Range("S" & i).Value = "C-MEM"
Range("W" & i).Value = ""
Range("AH" & i).Value = "N/A"
End If
End If
Next i
End Sub
I have some code which is designed to scan Columns F & G for occurrences of words found in an array, the array containing text found in Column J. If it finds occurrences in either Column F or Column G, it will copy and paste the terms into the corresponding columns.
Column J contains free text from a field in SAP. The field is free text so it could be "Kerry John Pub Expenses" or "CATS O/H Kerry John", or even "CATS John Kerry O/H". There is no data entry standard for this field; this is what makes this task difficult .
Column F and Column G contains first names and last names. The code makes an assumption, if it finds an entry in column F or G that matches an entry in the txt array, it will copy and paste that entry.
During testing, the code proved not sufficient to match the outcomes which I was looking for, and the solution to this problem would be to match text in Columns F and G concurrently for two matching words rather than doing them in separate intervals.
I would like some suggestions as to how this code could be re-written to achieve this result.
Example of successful code run
Here we have 4 rows of data, John Citizen is located in Row 3, therefore the blank cells in Columns F and G, Row 2 can be populated with his first and last name.
The problem
Because I have two rows that contain Kerry Citizen and John Kerry, the row is populated with Kerry Kerry as a result, where the entry should be "John" in Column F and "Kerry" in Column G
Code starts here
Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long
For I = 2 To Range("E50000").End(xlUp).row
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each T In txtArray
For J = 2 To Range("F50000").End(xlUp).row
If Range("F" & J).Value = T Then
match_txt = T
Range("F" & I).Value = match_txt
End If
Next J
Next T
For Each T In txtArray
For J = 2 To Range("G50000").End(xlUp).row
If Range("G" & J).Value = T Then
match_txt = T
Range("G" & I).Value = match_txt
End If
Next J
Next T
End If
Next I
End Sub
You can simplify your code greatly, and make it work, like this:
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
matchFound = False
For J = 2 To Range("G50000").End(xlUp).Row
If InStr(txt, Range("F" & J).Value) <> 0 _
And InStr(txt, Range("G" & J).Value) _
And Not (IsEmpty(Range("F" & J).Value)) _
And Not (IsEmpty(Range("G" & J).Value)) Then
'Both names match. Copy them.
Range("F" & I).Value = Range("F" & J).Value
Range("G" & I).Value = Range("G" & J).Value
matchFound = True
Exit For ' look no further.
End If
Next J
If Not matchFound Then MsgBox "No match found for: " & txt
End If
Tested, works for me.
The Code below runs for every first name on the list but only adds the name if both names match.
Sub arraycolumnmatch()
Dim txtArray As Variant, t As Variant
Dim I As Long, J As Long
For I = 2 To Range("G50000").End(xlUp).Row
typ = Range("F" & I).Value
If typ = "" And Not Range("J" & I).Value = Empty Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each word In txtArray
If Not word = "" Then
Set findtext = Range("F:F").Find _
(what:=(word), LookIn:=xlValues)
stoploop = False
loopcnt = 0
Do While Not findtext Is Nothing And stoploop = False And loopcnt < 21
loopcnt = loopcnt + 1
If InStr(txt, Range("F" & findtext.Row).Value) <> 0 _
And InStr(txt, Range("G" & findtext.Row).Value) Then
'Both names match. Copy them.
Range("F" & I).Value = Range("F" & findtext.Row).Value
Range("G" & I).Value = Range("G" & findtext.Row).Value
stoploop = True
Exit For ' look no further.
Else
Set findtext = Range("F" & findtext.Row & ":F" & 50000).Find _
(what:=(word), LookIn:=xlValues)
End If
Loop
End If
Next word
If Not stoploop Then MsgBox "No match found for: " & txt
End If
Next I
End Sub
Edit: Did an integration of #Jean InStr and a Find in Range which would allow for less loop time and a double match find.
I have had to stick with my original syntax, answer is below. Not the most efficient way of reaching the result, but it works
Sub arraycolumnmatch()
Dim txtArray As Variant, T As Variant
Dim I As Long, J As Long
For I = 2 To Range("E50000").End(xlUp).row
typ = Range("F" & I).Value
If typ = "" Then
txt = Range("J" & I).Value
txtArray = Split(txt, " ")
For Each T In txtArray
For J = 2 To Range("G50000").End(xlUp).row
If Range("G" & J).Value = T Then
match_txt = T
Range("G" & I).Value = match_txt
Exit For
End If
Next J
Next T
For Each T In txtArray
For J = 2 To Range("F50000").End(xlUp).row
If Range("F" & J).Value = T Then
match_txt = T
If Not Range("G" & I).Value = T Then
Range("F" & I).Value = match_txt
Exit For
End If
End If
Next J
Next T
End If
Next I