Here is a bit of background on what I'm trying to achieve.
I have an excel file, which contains 10 sheets and each of the sheets contain many rows of data. This workbook is sent to different people and each one fills in their respective info,only in columns A,B. I have made a vba script which loops through all the filled in workbooks, and checks which rows have cells Ax, Bx filled. Then it copies those in a new workbook.
So what I have right now is:
A workbook which contains only the rows of which the columns A,B have been filled.
A workbook which contains all unfilled rows. (the initial one)
What I want to do now is check row by row, and find e.g. Row 1 of sheet1 of workbook A, minus columns A,B, in workbook's B sheet 1. After the row is found I need to replace workbook's B row with the one from workbook A.
So in the end I will be left with one master workbook (previously workbook B) that will contain both filled and unfilled rows.
I hope I didn't make this too complicated. Any insight on what is the best way to achieve this would be appreciated.
Like I mentioned in my comments, it is possible to use .Find for what you are trying to achieve. The below code sample opens workbooks A and B. It then loops through the values of Col C in Workbook A and tries to find the occurrence of that value in Col C of Workbook B. If a match is found then it compares all columns in that row. And if all columns match then it writes to Col A and Col B of workbook B based on what the value is in workbook A. Once the match is found it uses .FindNext for further matches in Col C.
To test this, Save the files that you gave me as C:\A.xls and C:\B.xls respectively. Now open a new workbook and in a module paste this code. The code is comparing Sheet7 of workbook A with Sheet7 of workbook B
I am sure you can now amend it for rest of the sheets
TRIED AND TESTED (See Snapshot at end of post)
Sub Sample()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1LRow As Long, ws2LRow As Long
Dim i As Long, j As Long
Dim ws1LCol As Long, ws2LCol As Long
Dim aCell As Range, bCell As Range
Dim SearchString As String
Dim ExitLoop As Boolean, matchFound As Boolean
'~~> Open File 1
Set wb1 = Workbooks.Open("C:\A.xls")
Set ws1 = wb1.Sheets("sheet7")
'~~> Get the last Row and Last Column
With ws1
ws1LRow = .Range("C" & .Rows.Count).End(xlUp).Row
ws1LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'~~> Open File 2
Set wb2 = Workbooks.Open("C:\B.xls")
Set ws2 = wb2.Sheets("sheet7")
'~~> Get the last Row and Last Column
With ws2
ws2LRow = .Range("C" & .Rows.Count).End(xlUp).Row
ws2LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'~~> Loop Through Cells of Col C in workbook A and try and find it
'~~> in Col C of workbook 2
For i = 2 To ws1LRow
SearchString = ws1.Range("C" & i).Value
Set aCell = ws2.Columns(3).Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
ExitLoop = False
'~~> If match found
If Not aCell Is Nothing Then
Set bCell = aCell
matchFound = True
'~~> Then compare all columns
For j = 4 To ws1LCol
If ws1.Cells(i, j).Value <> ws2.Cells(aCell.Row, j).Value Then
matchFound = False
Exit For
End If
Next
'~~> If all columns matched then wrtie to Col A/B
If matchFound = True Then
ws2.Cells(aCell.Row, 1).Value = ws1.Cells(i, 1).Value
ws2.Cells(aCell.Row, 2).Value = ws1.Cells(i, 2).Value
End If
'~~> Find Next Match
Do While ExitLoop = False
Set aCell = ws2.Columns(3).FindNext(After:=aCell)
'~~> If match found
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
matchFound = True
'~~> Then compare all columns
For j = 4 To ws1LCol
If ws1.Cells(i, j).Value <> ws2.Cells(aCell.Row, j).Value Then
matchFound = False
Exit For
End If
Next
'~~> If all columns matched then wrtie to Col A/B
If matchFound = True Then
ws2.Cells(aCell.Row, 1).Value = ws1.Cells(i, 1).Value
ws2.Cells(aCell.Row, 2).Value = ws1.Cells(i, 2).Value
End If
Else
ExitLoop = True
End If
Loop
End If
Next
End Sub
SNAPSHOT
BEFORE
AFTER
Related
I am working currently with one workbook and want to implement a preparatory work, copy/pasting all the relevant range from my workbook contained in separate worksheets (3 worksheets at most).
I have the below code to loop through the worksheets, unfortunately I am unable to write the paste-command so as to paste these ranges from the same row successively. I want Transpose:= True. I.E Rgn from sheet1 starting from B2, after last filled cell on the right starts Rgn from Sheet2, after last filled cell starts Rgn from Sheet3 (provided Rgn exists for Sheet3).
Currently, my code overwrites what was copied from previous sheet.
I found a potential reference here (VBA Copy Paste Values From Separate Ranges And Paste On Same Sheet, Same Row Offset Columns (Repeat For Multiple Sheets)) but I am not sure how to use Address nor how the Offset is set in the solution.
' Insert temporary tab
Set sh = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
sh.Name = "Prep"
'Loop
For Each sh In wb.Worksheets
Select Case sh.Index
Case 1
Sheets(1).Range("D16:D18").Copy
Case 2
lastrow = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
lastcol = Sheets(2).Cells(9, Columns.Count).End(xlToLeft).Column
Set Rng = Sheets(2).Range("M9", Sheets(2).Cells(lastrow, lastcol))
Rng.Copy
Case 3
'Check if Range (first col for answers) is not empty
If Worksheetunction.CountA(Range("L9:L24")) = 0 Then
Exit For
Else
lastrow = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
lastcol = Sheets(3).Cells(9, Columns.Count).End(xlToLeft).Column
Set Rng = Sheets(3).Range("L9", Sheets(3).Cells(lastrow, lastcol))
Rng.Copy
End If
End Select
wb.Sheets("Prep").UsedRange.Offset(1,1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next
Set sh = Nothing
Set Rng = Nothing
Can you try this? UsedRange can be unpredictable. You can also have problems if you don't have anything in the first cell of Rng, in which case this code will need adjusting.
I would also prefer to use the sheeet name rather than index.
Sub x()
Dim sh As Worksheet, wb As Workbook, Rng As Range
Set sh = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
sh.Name = "Prep"
'Loop
For Each sh In wb.Worksheets
Select Case sh.Index
Case 1
Set Rng = sh.Range("D16:D18")
Case 2
lastrow = sh.Range("A" & Rows.Count).End(xlUp).Row
lastcol = sh.Cells(9, Columns.Count).End(xlToLeft).Column
Set Rng = sh.Range("M9", sh.Cells(lastrow, lastcol))
Case 3
'Check if Range (first col for answers) is not empty
If WorksheetFunction.CountA(sh.Range("L9:L24")) = 0 Then
Exit For
Else
lastrow = sh.Range("A" & Rows.Count).End(xlUp).Row
lastcol = sh.Cells(9, Columns.Count).End(xlToLeft).Column
Set Rng = sh.Range("L9", sh.Cells(lastrow, lastcol))
End If
End Select
Rng.Copy
wb.Sheets("Prep").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next
Set sh = Nothing
Set Rng = Nothing
End Sub
I have a workbook with 3 sheets: first one is the raw data sheet, then 2 target sheets. I would need a macro that would look at cell C in raw data sheet and based on the 2 values (YES or NO), will copy and paste the range A:Y in sheets 2, respectively 3.
Example: if on C2 in raw data sheet i have YES, copy A2:Y2 and paste into sheet 2, same range A2:Y2. If instead i have the value NO, copy A2:Y2 and paste into sheet 3.
Then go to next row and copy-paste A3:Y3 to sheet 2 if YES or A3:Y3 to sheet 3 if NO.
I wrote something that only works for the 2nd row, but i don't know how to make it loop... so basically when it passes to the next rows, it still copies the values from A2:Y2 to the target sheet, instead of copying A3:Y3, A4:Y4 etc..
Pasting my poor code below:
Sub IdentifyInfraction()
Dim rngA As Range
Dim cell As Range
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A2:Y2").Copy
Worksheets("Value_YES").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A2:Y2").Copy
Worksheets("Value_NO").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
End If
Next cell
End Sub
Please help!!! :-s
Easiest solution would just be to replace the number 2 in each of your ranges to a variable which you then increment at the end your statement, before you go to the next cell.
For example:
Dim i = 2
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_YES").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_NO").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
End If
i = i + 1
Next cell
So, originally we set i = 2, this is to go in line with your starting row of 2 mentioned in your question. Then, Range("A" & i & ":Y" & i).Copy is the same as saying Range("A2:Y2").Copy or Range("A3:Y3").Copy, etc.
This will go through any copy each row, a new row each time, and paste it to the respective row in the various sheets.
I hope this works for what you are trying to do, if not let me know.
There are a few things I'd also recommend looking into. There's a much better way to copy and paste, without going back and forward through the sheets.
ThisWorkbook.Sheets("raw_data").Rows(i).Copy Destination:=Worksheets("Value_YES").Range("A" & i)
Something like this would take the whole row from raw_data and transfer it to Value_YES. You'd have to mess around with it and change the range from Rows(i), but that's just an example.
I'd also recommend that you look into How to avoid using Select in Excel VBA to better understand why it's frowned upon to use Select and Activate in Excel VBA.
My version:
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ys.Range("A" & Yr)
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ns.Range("A" & Nr)
End If
Next c
End With
End Sub
If you really require to paste values, then use this one
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
Application.ScreenUpdating = False
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ys.Range("A" & Yr).PasteSpecial xlPasteValues
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ns.Range("A" & Nr).PasteSpecial xlPasteValues
End If
Next c
End With
Application.CutCopyMode = False
End Sub
you could try this:
Sub IdentifyInfraction()
Dim cell As Range
With Worksheets("raw_data") 'reference "raw data" sheet
For Each cell In .Range("C2", .cells(.Rows.Count, "C").End(xlUp)) ' loop through referenced sheet column C cells from row 2 down to last not empty one
Worksheets("Value_" & cell.Value).Range(cell.Address).Resize(, 25).Value = cell.Resize(, 25).Value 'have proper target sheet A:Y current cell row values as "raw data" sheet ones
Next
End With
End Sub
I am trying to enhance my current script. Sheet1 and Sheet2 contain only filepath names in column A. If a filepath in Sheet2 isn't found in Sheet1, it is copied over to sheet 3.
'row counter
x = 1
'Initiate Variables
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
'create a new sheet 3, delete old one if it exists
If Sheets.Count > 2 Then
Application.DisplayAlerts = False
Sheets(3).Delete
Application.DisplayAlerts = False
End If
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Sheet3"
Set ws3 = wb.Sheets("Sheet3")
'Get row count to know how many times to loop
rowCount2 = ws2.Range("A1").End(xlDown).Row
'compare filepaths from sheet2 to sheet1
'if there is a difference, that difference is put on sheet 3
For i = 1 To rowCount2
FilePath = ws2.Cells(i, 1)
With Sheets("Sheet1").Range("A:A")
Set CellId = .Find(What:=FilePath, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not CellId Is Nothing Then
'do nothing if filepath is found in both sheets
Else
'put the filepath from file2 not found in file1, into
'sheet 3
ws3.Cells(x, 1) = FilePath
x = x + 1
End If
End With
Next I
What I want to do, is be able to reference a range of cells to compare instead of just from column A. Instead of just file paths in column A, there will be last saved by in column B, Last opened by in column C, etc. So instead of just checking for difference in filepath, I want differences in multiple columns. So there might be the same filepaths, but it was opened by someone different on another day. I need to grab that difference. I don't know how to reference the range of multiple cells. So I need to fix up this section of code:
FilePath = ws2.Cells(i, 1)
With Sheets("Sheet1").Range("A:A")
And if there is an easier way to approach this I am open to advice.
In the 'do nothing if filepath is found in both sheets section, place something like this:
k = ws2.Cells(1,ws2.Columns.Count).End(xlToleft).Column
For j = 2 to k
If ws2.Cells(i, j).Value <> CellId.Offset(, j - 1).Value Then
CellId.EntireRow.Copy ws.Cells(x,1).EntireRow
x = x +1
Exit For
'or whatever code you need to move to sheet3
End If
Next
I use a Dictionary when comparing multiple list. This way I only iterate over each list one time.
Sub CopyMissingFileNames()
Dim filepath As Range, Target As Range
Dim dictFilePaths As Object
Set dictFilePaths = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
For Each filepath In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
If Not dictFilePaths.Exists(filepath.Text) Then dictFilePaths.Add filepath.Text, ""
Next
End With
With Worksheets("Sheet2")
For Each filepath In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
If Not dictFilePaths.Exists(filepath.Text) Then
Set Target = Worksheets("Sheet3").Range("A" & Rows.Count).End(xlUp).Offset(1)
filepath.EntireRow.Copy Target
End If
Next
End With
End Sub
I want a code that doing the following:
if the last 5 characters of the text value in the cell in column E is “(UK)” then the macro copies the range consisting of 4 cells in columns B,C,D,E in the same row and pastes below the last non-empty row in the worksheet “Sheet 1” in the same columns (so all ranges B-E with “(UK)” must be transferred to the sheet “Sheet1”);
I am just posting my code. Hope #Jonathan will learn it.
Sub CopyC()
Dim wb As Workbook
Dim ws As Worksheet
Dim sheet1lastrow As Long
Dim lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.Worksheets("sheet1")
lastrow = ActiveSheet.Range("E" & Rows.Count).End(xlUp).Row
sheet1lastrow = ws.Range("E" & Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Right(ActiveSheet.Cells(i, 5).Value, 5) = "(UK)" Then
ActiveSheet.Range(Cells(i, 2), Cells(i, 5)).Copy
ws.Cells(sheet1lastrow + 1, 2).PasteSpecial xlValues
Application.CutCopyMode = False
Application.CutCopyMode = True
End If
Next
End Sub
I don't use Excel very often, but I'm hoping there is a fairly straightforward way to get through this. I looked through a number of other solutions involving pasting data from one sheet to another, but I couldn't find anything that would allow me to (1) match a cell from one sheet to another and then (2) conditionally append or concatenate data instead of simply pasting it over.
I have an Excel document with two sheets of data. Both sheets contain a numerical ID column.
I basically need to match the ID's from Sheet2 to the Sheet1 and then append the row data from Sheet2 to the matching rows from Sheet1. I would imagine it will look something like this:
If Sheet2 ColumnA Row1 == Sheet1 ColumnA RowX
Copy Sheet2 Row1 Columns
Paste (Append) to Sheet1 RowX (without overwriting the existing columns).
Sorry if there is a better way to form this question. I've managed to think myself in circles and now I feel like I have a confused Nigel Tufnel look on my face.
[Update: Updated to clarify cells to be copied.]
I think this is what you are trying to do?
The code is untested. I believe it should work. If you get any errors, let me know and we will take it form there...
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1LR As Long, ws2LR As Long
Dim i As Long, j As Long, LastCol As Long
Dim ws1Rng As Range, aCell As Range
Dim SearchString
Set ws1 = Sheets("Sheet1")
'~~> Assuming that ID is in Col A
'~~> Get last row in Col A in Sheet1
ws1LR = ws1.Range("A" & Rows.Count).End(xlUp).Row
'~~> Set the Search Range
Set ws1Rng = ws1.Range("A1:A" & ws1LR)
Set ws2 = Sheets("Sheet2")
'~~> Get last row in Col A in Sheet2
ws2LR = ws2.Range("A" & Rows.Count).End(xlUp).Row
'~~> Loop through the range in Sheet 2 to match it with the range in Sheet1
For i = 1 To ws2LR
SearchString = ws2.Range("A" & i).Value
'~~> Search for the ID
Set aCell = ws1Rng.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If found
If Not aCell Is Nothing Then
LastCol = ws2.Cells(i, ws2.Columns.Count).End(xlToLeft).Column
'~~> Append values
For j = 2 To LastCol
ws1.Cells(aCell.Row, j).Value = ws1.Cells(aCell.Row, j).Value & " " & ws2.Cells(i, j).Value
Next j
End If
Next i
End Sub
HTH
Sid
This should work:
For Each cell2 In Sheet2.UsedRange.Columns(1).Cells
For Each cell1 In Sheet1.UsedRange.Columns(1).Cells
If cell2.Value = cell1.Value Then
Sheet1.Range("B" & cell1.Row & ":Z" & cell1.Row).Value = Sheet2.Range("B" & cell2.Row & ":Z" & cell2.Row).Value
End If
Next cell1
Next cell2