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
Related
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
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 want to delete a row if Column H contains any of the following values:
1) %
2) Resistor
3) Capacitor
4) MCKT
5) Connector
6) anything else I may want to add to this list...
Found this on Google and edited - it works well - not sure if there is a more "efficient" way to do it.
Sub DeleteRows()
lastrow = Cells.SpecialCells(xlCellTypeLastCell).Row
readrow = 1
For n = 1 to lastrow
If Range("H" & ReadRow).Value = "%" Or _
Range("H" & ReadRow).Value = "Resistor" Or _
Range("H" & ReadRow).Value = "Capacitor" Or _
Range("H" & ReadRow).Value = "MCKT" Or _
Range("H" & ReadRow).Value = "Connector" Then
Range("H" & ReadRow).EntireRow.Delete
Else
readrow = readrow + 1
End If
Next
End Sub
There are more efficient methods but with this one:
loop backwards.
Change the ReadRow to n, no sense in having two variables:
code:
Sub DeleteRows()
Dim Lastrow as long, n as long
lastrow = Cells.SpecialCells(xlCellTypeLastCell).Row
For n = lastrow to 1 Step -1
If Range("H" & n).Value = "%" Or _
Range("H" & n).Value = "Resistor" Or _
Range("H" & n).Value = "Capacitor" Or _
Range("H" & n).Value = "MCKT" Or _
Range("H" & n).Value = "Connector" Then
Rows(n).Delete
End If
Next
End Sub
Another method is to use Select Case
Sub DeleteRows()
Dim Lastrow as long, n as long
lastrow = Cells.SpecialCells(xlCellTypeLastCell).Row
For n = lastrow to 1 Step -1
Select Case Range("H" & n).Value
Case "%","Resistor","Capacitor","MCKT","Connector"
Rows(n).Delete
End Select
Next
End Sub
It makes it easier to add to the list.
This worked great.
Option Explicit
Option Compare Text
Sub Delete_Rows()
Dim LastRow As Long, ReadRow As Long, n As Long
With ThisWorkbook.Sheets("Sheet1")
LastRow = .Cells(.Rows.Count, "H").End(xlUp).row
End With
ReadRow = 1
For n = 1 To LastRow
If Range("H" & ReadRow).Value Like "*%*" = True Or _
Range("H" & ReadRow).Value Like "*Resistor*" = True Or _
Range("H" & ReadRow).Value Like "*Transistor*" = True Or _
Range("H" & ReadRow).Value Like "*Micro*" = True Then
Range("H" & ReadRow).EntireRow.Delete
Else
ReadRow = ReadRow + 1
End If
Next
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 am working on a macro to loop through staggered columns of strings and concatenate them. Basically data gets added into the columns over time so I need to make it "future-proof". At the moment it picks up all of column H and I but only the first value of J and K. Not sure why it works for half but not the other. I am thinking its to do with my .End(xldown) as i am used to using rows.end(xlup).count to loop through things, but never when it is part of the range?
Here is my code:
Sub Concatenation_for_the_nation()
Range("H2").End(xlDown).Select
For i = 1 To ActiveCell.Row
Range("H" & i).Select
StrStrONE = StrStrONE & " " & Selection
Next i
Cells(1, 1).Select
Range("I2").End(xlDown).Select
For j = 1 To ActiveCell.Row
Range("I" & j).Select
StrStrTWO = StrStrTWO & " " & Selection
Next j
Cells(1, 1).Select
Range("J2").End(xlDown).Select
For k = 1 To ActiveCell.Row
Range("J" & k).Select
StrStrTHREE = StrStrTHREE & " " & Selection
Next k
Cells(1, 1).Select
Range("K2").End(xlDown).Select
For l = 1 To ActiveCell.Row
Range("K" & l).Select
StrStrFOUR = StrStrFOUR & " " & Selection
Next l
Cells(1, 1).Select
Cells(21, 21) = StrStrONE & StrStrTWO & StrStrTHREE & StrStrFOUR
Cells(20, 20) = "Jeff"
MsgBox "steve the pirate"
End Sub
You're repeating the same logic multiple times, so it makes sense to pull it out into a separate Sub.
Tested:
Sub Concatenation_for_the_nation()
Dim c As Range, s As String, sht As Worksheet
Set sht = ActiveSheet
For Each c In sht.Range("H1:K1")
s = s & ColumnString(c)
Next c
sht.Cells(21, 21).Value = s
sht.Cells(20, 20).Value = "Jeff"
MsgBox "arrrrr"
End Sub
Function ColumnString(cStart As Range, Optional sep As String = " ")
Dim rng As Range, c As Range, rv As String
Set rng = cStart.Parent.Range(cStart, _
cStart.Parent.Cells(Rows.Count, cStart.Column).End(xlUp))
For Each c In rng.Cells
rv = rv & sep & c.Value
Next c
ColumnString = rv
End Function