I'm using the below code. My goal is to change this row:
cell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
If the number in Sheet1 A2 matches Sheet2 A2
Then copy the data from Sheet1 P2 to Sheet2 P2
(and consecutively if Sheet1 A3 = Sheet2 A3 THEN copy Sheet1 P3 to Sheet2 P3 all the way down the list).
Sub Sheet1Sheet2Compare()
Dim lRow, x As Long
Sheets("Sheet1").Select
lRow = Range("A1").End(xlDown).Row
For Each cell In Range("A2:A" & lRow)
x = 2
Do
If cell.Value = Sheets("Sheet2").Cells(x, "A").Value Then
cell.EntireRow.Copy Sheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
x = x + 1
Loop Until IsEmpty(Sheets("Sheet2").Cells(x, "A"))
Next
End Sub
try this
Sub Sheet1Sheet2Compare()
Dim lRow As Integer, x As Integer, i As Integer
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")
lRow = sht1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lRow
If sht1.Range("A" & i).Value = sht2.Range("A" & i).Value Then sht2.Range("P" & i).Value = sht1.Range("P" & i).Value
Next i
End Sub
Related
When I use ClearContent on a cells which other cells next to it uses formulas, it changes the formulas in those other cells. For example:
.Range("L" & x2 & ":M" & x2).ClearContents
I have formula in N2 which is now =IFERROR(F3/G3*3600,0), I need it to stay =IFERROR(F2/G2*3600,0), the next row N3 now is =IFERROR(#REF!/#REF!*3600,0)
Actual Code:
Dim Sht1 As Worksheet, Sht2 As Worksheet
Dim LstRw As Long, lookup_rng As Range, x
Dim Sht3 As Worksheet, Sht4 As Worksheet
Dim LstRw2 As Long, lookup_rng2 As Range, x2
Set Sht1 = Sheets("Pick Ticket Schedule")
Set Sht2 = Sheets("Pick Ticket (History)")
Set lookup_rng = Sht2.Range("B2:B10")
With Sht1
LstRw = .Cells(.Rows.Count, "T").End(xlUp).Row
For x = LstRw To 2 Step -1
'MsgBox "LstRw:" & LstRw & " " & x & "-" & .Cells(x, 20).Value & " -->" & lookup_rng.Value
If Not lookup_rng.Find(what:=.Cells(x, 20), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
Sht1.Range("J" & x & ":K" & x).ClearContents 'Shift:=xlUp <-- Only used for delete 'Need to delete value in cell J & K for the row that matches
Sht1.Range("T" & x).ClearContents
End If
Next x
End With
Set Sht3 = Sheets("Master Production Schedule")
Set Sht4 = Sheets("Historical FG")
Set lookup_rng2 = Sht4.Range("B2:B10")
With Sheets("Master Production Schedule")
LstRw2 = .Cells(.Rows.Count, "V").End(xlUp).Row
For x2 = LstRw2 To 2 Step -1
If lookup_rng2.Find(what:=.Cells(x2, 22), LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
.Range("L" & x2 & ":M" & x2).ClearContents 'Need to delete value in cell L & M for the row that matches
.Range("T" & x2).ClearContents
.Range("V" & x2).ClearContents
End If
Next x2
End With
Column O with cells O2 and O3 are also affected in a similar way, I am assuming these 2 are somehow affected by Column L & M. Only Row 2 and Row 3 have data for those columns. What would be the best way to make it so it doesn't affect the following rows? Thanks in advance! -Paul
So I have an excel sheet where I want to loop through Sheet1 and find data pairs similar to Sheet2. So, I have for example A1:B1 and I need to find a row on Sheet2 that has exactly the same values next to each other (but it could be A33:B33 or anywhere) and copy the row over to Sheet1 (in column C or anything)
I am also trying to make it a dynamic loop so it checks for A1:B1 pair against Sheet2 then A2:B2 and so on until the last row.
Now the code I have only checks if A1:B1 on Sheet1 matches A1:B1 on Sheet2 (but not anywhere on the sheet). Also, I cannot make it so that it dynamically checks against every row on Sheet1 (I tried to make it with the x = x + 1 but it doesn't work)
Here is my code:
Sub matchme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
r = lastrow = sh1.Range("A" & Rows.Count).End(xlUp).Row
For x = 1 To r
If sh1.Range("A" & x) = sh2.Range("A" & x) And sh1.Range("B" & x) = sh1.Range("A" & x) & sh2.Range("B" & x) Then
sh1.Range("A" & x).EntireRow.Copy Destination:=sh2.Range("C" & x)
x = x + 1
Next x
End Sub
Please help, I have been struggling with this for days now and I need to hand in a report by the end of today, and I just cannot find anything helpful on the internet. I really appreciate any advice
If You want to use loops, try that:
Sub matchme()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim x As Long
Dim i As Long
Dim j As Long
Dim lastrow As Long
Dim lastRow2 As Long
Dim lastCol2 As Long
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastrow = sh1.Range("A" & Rows.Count).End(xlUp).Row
With sh2
lastRow2 = .Cells(Rows.Count, 1).End(xlUp).Row
lastCol2 = .Cells(1, Columns.Count).End(xlUp).Column
End With
For x = 1 To lastrow
For i = 1 To lastRow2
For j = 1 To lastCol2
If sh1.Cells(x, 1) = sh2.Cells(i, j) Then
If sh1.Cells(x, 2) = sh2.Cells(i, j + 1) Then
MsgBox "Found match!"
End If
End If
Next j
Next i
Next x
End Sub
I haven't tested this.
I've assumed you are searching for sheet1 A values in sheet2 column A only.
When a match is found, the column C value on sheet2 is copied to column C on sheet1.
Sub x()
Dim rFind As Range, s As String, r As Range
With Sheet1
For Each r In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFind = Sheet2.Columns(1).Find(What:=r.Value, Lookat:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
s = rFind.Address
Do
If rFind.Offset(, 1).Value = r.Offset(, 1).Value Then
r.Offset(, 2).Value = rFind.Offset(, 2).Value
End If
Set rFind = Sheet2.Columns(1).FindNext(rFind)
Loop While rFind.Address <> s
End If
Next r
End With
End Sub
To get the pairs of Sheet1 and look for them in Sheet2:
I've used this code:
Application.ScreenUpdating = False
Dim i As Long
Dim LastRow As Long
Dim rng As Range
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim SearchThis As String
Set wk1 = ThisWorkbook.Worksheets("Sheet1")
Set wk2 = ThisWorkbook.Worksheets("Sheet2")
LastRow = wk1.Range("A" & wk1.Rows.Count).End(xlUp).Row
'<--------------------------------->
'For more type of SPECIAL CELLS, and choose exactly the type you need
'please read https://learn.microsoft.com/en-us/office/vba/api/excel.range.specialcells
For i = 1 To LastRow Step 1
SearchThis = UCase(wk1.Range("A" & i).Value & wk1.Range("B" & i).Value)
For Each rng In wk2.Cells.SpecialCells(xlCellTypeConstants, 23)
If UCase(rng.Value & rng.Offset(0, 1).Value) = SearchThis Then
'code to copy where you want
Debug.Print rng.Row
End If
Next rng
Next i
Set wk1 = Nothing
Set wk2 = Nothing
Application.ScreenUpdating = True
The output of this code is:
Those are the row numbers where the pairs are. You just need to add a code to copy the entire row.
Hope this helps
Try below code (comments in code):
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
lastRow = sh1.Range("A" & Rows.Count).End(xlUp).Row
iLastRow = sh2.Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To lastRow
For i = 1 To iLastRow
If sh1.Cells(j, 1) = sh2.Cells(i, 1) And sh1.Cells(j, 2) = sh2.Cells(i, 2) Then
sh1.Cells(i, 3) = "Write some information"
End If
'you don't need to increment loop variable "Next" does it for you
'also i is better suited for iterator name :)
Next
Next
'Sub CopyRowToSheet23()
Worksheets("Sheet2").Range("A2:E1000").Clear
Dim LastRowSheet1, LastRowSheet2 As Long
Dim i As Long
Application.ScreenUpdating = False
LastRowSheet2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A2:E" & LastRowSheet2).ClearContents
LastRowSheet1 = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("Sheet1")
For i = 2 To LastRowSheet1 Step 1
If Cells(i, "E").Value = "YES" Then
LastRowSheet2 = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Rows(i).Copy Worksheets("Sheet2").Range("A" & LastRowSheet2 + 1)
End If
Next i
End With
Application.ScreenUpdating = True
Sheet3.Select
End Sub'
I´ve managed to create the code above to get all rows that have "yes" in column E. However, I´m having issues when trying to run the macro in other sheets different than Sheet1. I would like to run it in sheet3 but I haven´t found why it does not help.
Try:
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim wsRE As Long, i As Long, LastrowC As Long, LastrowE As Long, LastrowF As Long
'Set ws1
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
'Set ws2
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
wsRE = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
'Starting from Row 2 - let us assume that their is a header
For i = 2 To wsRE
'Check if the value in column E is yes
If ws2.Range("E" & i).Value = "Yes" Then
'Find the Last row in Sheet1 Column C
LastrowC = ws1.Cells(ws1.Rows.Count, "C").End(xlUp).Row
'Copy row i, Column A from Sheet 1 and paste it in Sheet 2 after the lastrow in column C
ws2.Range("A" & i).Copy ws1.Cells(LastrowC + 1, 3)
'Find the Last row in Sheet1 Column E
LastrowE = ws1.Cells(ws1.Rows.Count, "E").End(xlUp).Row
'Copy row i, Column B from Sheet 1 and paste it in Sheet 2 after the lastrow in column E
ws2.Range("B" & i).Copy ws1.Cells(LastrowE + 1, 5)
'Find the Last row in Sheet1 Column F
LastrowF = ws1.Cells(ws1.Rows.Count, "F").End(xlUp).Row
'Copy row i ,Column C from Sheet 1 and paste it in Sheet 2 after the lastrow in column F
ws2.Range("C" & i).Copy ws1.Cells(LastrowF + 1, 6)
End If
Next i
End Sub
I need a macro to write the row values present in column A if there is a value present in column B .
For example :
Column A Column B
Arjun
Arun 12
For the above example, I need a macro which can write "Arun 12" in Sheet2 of the work book with the Headers "Name" and "Hours".Before this the macro should clear the data present in Sheet two completely.
This will copy the all rows of columns A and B from Sheet1 to Sheet2 if B is not a Null string. And also will add the headers "Name" and "Hours".
Option Explicit 'requires that every variable has to be defined before use, e.g. with a Dim statement.
Sub DoStuff_GoodPractice()
Dim lastRowSrc As Long, lastRowDest As Long, i As Long 'declare row counts as Long so all rows can be used
Dim shtSource As Worksheet, shtDestination As Worksheet
Set shtSource = ThisWorkbook.Worksheets("Sheet1") 'full qualified identification of the worksheets
Set shtDestination = ThisWorkbook.Sheets("Sheet2")
lastRowSrc = shtSource.Range("A" & shtSource.Rows.Count).End(xlUp).Row 'determine the last used row
'clear destination sheet and write headers:
shtDestination.Cells.Clear
shtDestination.Range("A1").Value = "Name"
shtDestination.Range("B1").Value = "Hours"
lastRowDest = 1 'start with row 1 as destination
For i = 1 To lastRowSrc 'loop through all used rows
If shtSource.Range("A" & i).Value <> vbNullString And _
shtSource.Range("B" & i).Value <> vbNullString Then 'check if cells are not a null string
shtSource.Range("A" & i & ":B" & i).Copy Destination:=shtDestination.Range("A" & lastRowDest + 1) 'copy current row
lastRowDest = lastRowDest + 1 'jump to the last used row in destination
End If
Next i
End Sub
This should accomplish what you're after.
Sub DoStuff()
Dim lastRow As integer, lastRowSheet2 As integer, i As Integer
Dim sheet1 As WorkSheet, sheet2 As Worksheet
Set sheet1 = Sheets("Sheet1")
Set sheet2 = Sheets("Sheet2")
lastRow = sheet1.Range("A" & Rows.Count).End(xlUp).Row
sheet2.Cells.Clear
For i = 1 To lastRow
If sheet1.Range("A" & i).Value <> "" And sheet1.Range("B" & i).Value <> "" then
lastRowSheet2 = sheet2.Range("A" & Rows.Count).End(xlUp).Row
sheet1.Range("A" & i & ":B" & i).Copy Destination:= sheet2.Range("A" & lastRowSheet2 + 1)
End If
Next i
End Sub
I Have a Column C that has names in all its cells and another Column E that has the same company name in all its cells I need to append the names in Column C to the company name in column E
Thanks
Ex:
ColC ColE
Bob SampleCo
Sally SamplCo
I get
ColC ColE
Bob SampleCo Bob
Sally SamplCo Sally
I am trying but failing with
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Dim rRange As range
Set rRange = range("E2")
rRange.Select
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.range("F" & Ws.Rows.Count).End(xlUp).Row
Ws.range("E2:E" & LastRow).FormulaR1C1 = "=rRange &RC[-1]"
range("E2:E" & LastRow).Copy
range("E2:E" & LastRow).PasteSpecial xlPasteValues
End Sub
Code
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.Range("E" & Ws.Rows.Count).End(xlUp).Row
Ws.Range("F2:F" & LastRow).FormulaR1C1 = "= RC[-1] & "" "" & RC[-3]"
End Sub
If you want the output in Column E its not possible using FormulaR1C1.
Any formula which work for excel interface will work for FormulaR1C1.
With that i mean (considering the image) in cell F2 you can manullay enter a formula = E2 & " " & C2 which will give you desired output. But if you enter in cell E2the formula as =E2 & " " & C2 the cell E2 will loose its value and this may even lead to circular reference issue.
It can be achieved using below code.
Sub CompanyName()
Dim LastRow As Long
Dim Ws As Worksheet
Dim rng As Range, cell As Range
Set Ws = Sheets("WP_SubjectList_Ready")
LastRow = Ws.Range("E" & Ws.Rows.Count).End(xlUp).Row
Set rng = Ws.Range("E2:E" & LastRow)
For Each cell In rng
cell = cell & " " & cell.Offset(0, -2)
Next
End Sub
Here's some code that should help you with what you want...I don't typically use ranges for loops because it's easier to use .Cells(row, col) for me, but anyways:
EDIT: Added Sub Opening/Closing Syntax and edited to use WS instead of ActiveSheet so it's closer to what you want
Sub CompanyName()
Dim WS as Worksheet
Dim vRow
Dim vRowCount As Integer
Set WS = Sheets("WP_SubjectList_Ready")
'Gets Row # of Last Row for Column E
vRowCount = Range("E" & Rows.Count).End(xlUp).row
'Assuming Both Columns have the same row count and you have a header row
For vRow = 2 To vRowCount
WS.Cells(vRow, 5).Value = WS.Cells(vRow, 5).Value & " " & WS.Cells(vRow, 3).Value
Next vRow
End Sub