I have a workbook with multiple sheets (Sheet 1, 2...etc) and a "Master" Sheet. I need to select a range from columns A:C until it meets a row with the value (tva) (including those rows). I want to compare that range from Master to the other sheets, and highlight the differences.
Sample image For example Master sheet has in A3 value "m".
This is what I have so far. I'm pretty new at this so any advice is appreciated :)
Sub comp()
Dim ws As Worksheet
Dim rngCell As Range
For Each ws In ThisWorkbook.Worksheets
ws.Activate
rngCell = Columns("A:C").Resize(Columns("A:C").Find(What:="tva", After:=Range("A1"), LookIn:=xlValues, SearchDirection:=xlPrevious).Row)
rngCell.Select
For Each rngCell In ws.Range
If Not rngCell = Worksheets("Master").Cells(rngCell.Row, rngCell.Column) Then
rngCell.Interior.Color = vbYellow
End If
Next ws
End Sub
You can try following code, although it is did not cover other column, but small adjustment only need to check until column C (col 3):
Sub comp()
Dim ws As Worksheet
Dim valuerow As Long, irow As Long
For Each ws In ThisWorkbook.Worksheets
ws.Activate
valuerow = Cells.Find(What:="tva", After:=Range("A1"), LookIn:=xlValues, SearchDirection:=xlPrevious).Row
For irow = 1 To valuerow
If ws.Cells(irow, 1).Value <> Worksheets("Master").Cells(irow, 1).Value Then
ws.Cells(irow, 1).Interior.Color = vbYellow
End If
If ws.Cells(irow, 2).Value <> Worksheets("Master").Cells(irow, 2).Value Then
ws.Cells(irow, 2).Interior.Color = vbYellow
End If
Next
Next
End Sub
Related
Looking to fill a variable range here. I can fill my formula to the right but when I want to fil it down, the formula disappears. I have also attached a picture and Column A starts with "Fund Name". Hope somebody can help me here thank you!! The link to the table is here. 1: https://i.stack.imgur.com/y1ZVH.png
Sub Six_Continue()
Dim Lastrow As Long
Dim lrow As Range
Dim Lastcol As Long
Dim lcol As Range
Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Set lrow = Range("C5:C" & Lastrow)
Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
Set lcol = Range("C3", Cells(3, Lastcol))
Range("C5").FormulaArray = "=IFERROR(INDEX(DataTable[[Period]:[Period]],SMALL(IF(DataTable[[LP ID]:[LP ID]]=C$2,IF(DataTable[[Fund ID]:[Fund ID]]=$B5,ROW(DataTable[[Fund ID]:[Fund ID]])-ROW(DataTable[[Fund ID]:[Fund ID]]))),1)),"" "")"
Range("C5", lcol.Offset(2)).FillRight
Range("C5", lcol.Offset(2)).FillDown
End Sub
The code below worked for me (with a much simplified array formula).
Sub Six_Continue()
' 25 Jan 2018
Dim Rng As Range
Dim LastRow As Long
Dim LastClm As Long
With ActiveSheet ' better specify by name
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastClm = .Cells(1, .Columns.Count).End(xlToLeft).Column
Cells(5, 3).FormulaArray = "=IFERROR(INDEX(DataTable[[Period]:[Period]],SMALL(IF(DataTable[[LP ID]:[LP ID]]=C$2,IF(DataTable[[Fund ID]:[Fund ID]]=$B5,ROW(DataTable[[Fund ID]:[Fund ID]])-ROW(DataTable[[Fund ID]:[Fund ID]]))),1)),"" "")"
' .Cells(5, 3).FormulaArray = "= $a1 * $k1:$k5 * C$1"
Set Rng = Range(.Cells(5, 3), .Cells(5, LastClm))
Rng.FillRight
Set Rng = Range(.Cells(5, 3), .Cells(LastRow, LastClm))
Rng.FillDown
End With
End Sub
I have code that will loop through my worksheet, but it performs copies all of the rows and not just the ones based on my criteria. How would I get it to only copy the row I want?
Sub Major2_Paster()
Dim LastRow As Integer
Dim i As Integer
Dim erow As Integer
LastRow = Cells(Rows.count, 1).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 12) = “MLA” Then
range(Cells(i, 1), Cells(i, 21)).Select
Selection.Copy
Workbooks.Open Filename:="H:\Degrees List\Sorted_Workbooks\MLA Mar-17.xlsx"
erow = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If
Next i
End Sub
A couple of things:
Only open the workbook once, this will be the most significant performance boost
Create references to workbooks/worksheets rather than using ActiveSheet/ActiveWorkbook
Indenting is so important. It makes code so much more readable and it's the first step in finding your own errors
Sub Major2_Paster()
Dim LastRow As Integer, i As Integer, erow As Integer
Dim destinationWorkbook As Workbook
Dim sourceWorksheet As Worksheet, destinationWorksheet As Worksheet
Set destinationWorkbook = Workbooks.Open(Filename:="H:\Degrees List\Sorted_Workbooks\MLA Mar-17.xlsx")
Set sourceWorksheet = ThisWorkbook.Worksheets("SheetName")
Set destinationWorksheet = destinationWorkbook.Worksheets("SheetName")
With sourceWorksheet
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 2 To LastRow
If sourceWorksheet.Cells(i, 12).Value = “MLA” Then
With destinationWorksheet
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
destinationWorksheet.Cells(erow, 1).Resize(1, 21).Value = sourceWorksheet.Range(sourceWorksheet.Cells(i, 1), sourceWorksheet.Cells(i, 21)).Value
End If
Next i
destinationWorkbook.Close SaveChanges:=True
Application.CutCopyMode = False
End Sub
Each week I get new data and I m filtering for for "n/a" column from another sheet and grabbing the rest of the columns and adding them to my existing sheet of the same workbook and I need to color the rows that have dates smaller than tomorrow's date, so today or prior. New data range varies each week and I only want to color new data. I am checking dates using column D and there are also dates in column C so I don't know if that will complicate the task.
I know this can be achieved using conditional formatting, but I want to use vba codes to automate the process.
My codes won't work since it can't determine where my new data starts and only colors column D not the whole row if it fits the criteria. Please see my codes and my desire result.
Sub paste_value()
Dim ws1, ws2 As Worksheet
Dim lr1, lr2 As Long
Dim rCell As Range
'filter
Set ws1 = Worksheets("All Renewals_V2")
Set ws2 = Worksheets("Renewal policies")
lr1 = ws1.Cells(Rows.Count, "B").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
'copy range from column B to column R
With ws1.Range("B2", "R" & lr1)
.AutoFilter Field:=1, Criteria1:="#N/A"
'paste result from column A
.Copy Destination:=Cells(lr2, "A")
End With
For Each rCell In .Range("D5", .Cells(.Rows.Count, 4).End(xlUp)).Cells
If rCell.Value <= Date + 1 Then
rCell.Interior.color = vbYellow
End If
Next rCell
End Sub
If I am understanding your question correctly, I think the following modifications to your code will enable it to work:
Sub paste_value()
'Dim ws1, ws2 As Worksheet
'Dim lr1, lr2 As Long
'existing code declared ws1 and lr1 as Variants
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long
Dim rCell As Range
'filter
Set ws1 = Worksheets("All Renewals_V2")
Set ws2 = Worksheets("Renewal policies")
'lr1 = ws1.Cells(Rows.Count, "B").End(xlUp).Row
'Should qualify which sheet "Rows" refers to
lr1 = ws1.Cells(ws1.Rows.Count, "B").End(xlUp).Row
'lr2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
'Need to add 1 or else the first row of this week will replace the last
'row of last week
lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1
'copy range from column B to column R
With ws1.Range("B2", "R" & lr1)
.AutoFilter Field:=1, Criteria1:="#N/A"
'paste result from column A
'.Copy Destination:=Cells(lr2, "A")
'Should specify that ws2 is the sheet to which "Cells" refers
.Copy Destination:=ws2.Cells(lr2, "A")
End With
'I am guessing that the following statement is missing
With ws2
'For Each rCell In .Range("D5", .Cells(.Rows.Count, 4).End(xlUp)).Cells
'Need to start the colouring from the first row pasted in
For Each rCell In .Range("D" & lr2, .Cells(.Rows.Count, 4).End(xlUp)).Cells
If rCell.Value <= Date + 1 Then
'rCell.Interior.color = vbYellow
'Change as per Scott Holtzman's comment
rCell.Offset(, -3).Resize(1, 5).Interior.Color = vbYellow
'Or an alternate version would be
' rCell.EntireRow.Columns("A:E").Interior.Color = vbYellow
'Use whichever version makes the most sense to you
End If
Next rCell
End With
End Sub
I would really appreciate some help to find a correct approach to solve my issue.
I am attempting to loop through all worksheets (except for "Sheet 1" and "Output".
All the above referenced worksheets contain data from cell A2 to last column and last row. I need to copy all the looped ranges (one below the other) in cell C2 in my "Output" worksheet.
Also I have a unique number in A1 in all worksheets (except for "Sheet 1" and "Output" that needs to be copied into B2 in my "Output" worksheet. The trick is (which i am struggling with) the value in A1 needs to be copied down B2 in my "Output" worksheet by the number A2:last row in all my looped worksheets.
Below is my code thus far:
Sub EveryDayImShufflingData()
Dim ws As Worksheet
Dim PasteSheet As Worksheet
Dim Rng As Range
Dim lRow As Long
Dim lCol As Long
Dim maxRow As Integer
Dim x As String
Set PasteSheet = Worksheets("Output")
Application.ScreenUpdating = False
'Loop through worksheets except "Sheet 1" and "Output"
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
'Select the Worksheet
ws.Select
'With each worksheet
With ws
'Declare variables lRow and lCol
lRow = .Cells(Rows.Count, 1).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'Set range exc. VIN
Set Rng = .Range(.Cells(2, 1), .Cells(lRow, lCol))
'Paste the range into "Output" worksheet
Rng.Copy
PasteSheet.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
x = .Cells(1, 1).Value
For i = 1 To lRow
PasteSheet.Cells(i, 2).End(xlUp).Offset(1, 0) = x
maxRow = maxRow + 1
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End With
End If
Next ws
End Sub
Any assistance would be kindly appreciated
Try this:
Sub EveryDayImShufflingData()
Dim ws As Worksheet, copyRng As Range, lRow As Long, lCol As Long, PasteSheet As Worksheet
Set PasteSheet = Worksheets("Output")
For Each ws In ActiveWorkbook.Worksheets
If (ws.Name <> "Sheet1") And (ws.Name <> "Output") And (ws.Visible = True) Then
lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
Set copyRng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol))
copyTargetCell = PasteSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1
copyRng.Copy Destination:=PasteSheet.Range("C" & copyTargetCell)
Worksheets("Output").Range("B" & copyTargetCell & ":B" & (copyTargetCell + copyRng.Rows.Count - 1)) = ws.Range("A1")
End If
Next ws
End Sub
Since hours now I'm struggling with the same problem now...
I try to copy certain rows upon a condition in column A to an other Workbook. I don't get an error message, the code runs through, but nothing happens. Somehow it seems not to "see" the lines between Then and End If. If I run the code manually, the line directly jumps to End if and further repeats the loop.
Do you have any idea what could be wrong? - Thanks for any help!
This part of my code lookes like:
Dim LastRow As Integer, i As Integer
LastRow = Workbooks("Workb1.xlsx").Sheets("Sheet1").Cells(Rows.Count,"A").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2).Value = "848" Then
Range(Cells(i, 2), Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
After your first comments, the edited code now is:
Dim LastRow As Integer, i As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("Workb1").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4
For i = 1 To LastRow
If .Cells(i, 1).Value = 848 Then
Range(.Cells(i, 1)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
End With
Ok, What I actually want to do:
Always copy from source to target sheet
First only for rows, which have a 848 in column A and paste them to target. So for all those rows, which have an 848 in column A:
Copy value in the column X in “source” --> Column Y in “target”
A --> A N-->B O-->C AM -->D AH -->G P-->I E-->J F-->K
Now, only consider those cells with a 618 in column A and copy/paste, again to the firs empty cell in this column (so after the rows with 848, now the target-sheet gets completed with the 618 cells.
A --> A N-->B O-->C AM -->D T -->G P-->I E-->J F-->K
Column E and F in the target: there are formula, which have to be elongated to the end of the column
I did change that much until now, that it's not even a working code anymore...
Private Sub CommandButton1_Click()
Dim LastRow As Integer, i As Integer, erow As Integer, LastRow2 As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("macro_source").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4
For i = 2 To LastRow
If .Cells(i, 1).Value = 848 Then
Workbooks("macro_source").Sheets("Sheet1").Activate
.Cells(i, 1).Copy
Set erow = Workbooks("destination.xlsx").Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
End With
End Sub
Maybe I have to add, that both files are pre-edited by the prior code, which I did not show here. And I still did not find out whether it's possible to upload the data as excel files...
Many thanks for your help again, I really stuck...
copying between books seems to go wrong fairly often even when what you have coded seems to logically be correct.
I have found in the past it's better to reference the sheet then use the reference and to use the with statement as it seems to handle range selections better
Some code below should work for you... (I have altered the paste to start at A1 and increment each time as the original code would overwrite each time it found a value - you should be able to edit to paste where you want)
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("Workb1.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long: j = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 2 To LastRow
If .Cells(i, 1).Value = "848" Then
.Range(.Cells(i, 2), .Cells(i, 14)).Copy
wsDest.Range("A" & j).PasteSpecial xlPasteValues
j = j + 1
End If
Next i
End With
End Sub
UPDATE
For searching against multiple values
Sub CopyToNewBook()
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = Workbooks("Workb1.xlsx")
Dim wbDest As Workbook: Set wbDest = Workbooks("destination.xlsx")
If wbSrc Is Nothing Or wbDest Is Nothing Then
MsgBox "Please open both workbooks required"
Exit Sub
End If
On Error GoTo 0
Dim SearchValues() As String: SearchValues = Split("848,618", ",")
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Sheets("Sheet1")
Dim wsDest As Worksheet: Set wsDest = wbDest.Sheets("Sheet1")
Dim LastRow As Long, i As Long, j As Long, z As Long: z = 63976
With wsSrc
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For j = 0 To UBound(SearchValues)
For i = 2 To LastRow
If .Cells(i, 1).Value = SearchValues(j) Then
.Range(.Cells(i, 2), .Cells(i, 14)).Copy
wsDest.Range("A" & z).PasteSpecial xlPasteValues
z = z + 1
End If
Next i
Next j
End With
End Sub
To add to my comment
you're also counting the number of rows in column A and running the loop on column B. I'd also set your cells as it could be looking at the wrong sheet
Dim LastRow As Integer, i As Integer
Dim ws as worksheet
set ws = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws.Cells(Rows.Count,"B").End(xlUp).Row
with ws
For i = 2 To LastRow
If .Cells(i, 2).Value = 848 Then
Range(.Cells(i, 2), .Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Paste
End If
Next i
end with
Update:
you could simplify a lot of this
Dim LastRow As Integer, i As Integer
Dim ws as worksheet
set ws = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws.Cells(Rows.Count,"B").End(xlUp).Row
with ws
For i = 2 To LastRow
If Trim(Val(.Cells(i, 1))) = 848 Then
Range(.Cells(i, 2)).Copy _
destination:=Workbooks("destination.xlsx") _
.Worksheets("Sheet1").Range("A63976").Paste
End If
Next i
end with
This code will work fine. Check your cell that has 848 in it manually and make sure it is an integer.
Try this:
Dim LastRow As Integer, i As Integer
Dim ws4 As Worksheet
Set ws4 = Workbooks("Workb1.xlsx").Sheets("Sheet1")
LastRow = ws4.Cells(Rows.Count, "A").End(xlUp).Row
With ws4.Columns(1)
For i = 1 To LastRow
If .Cells(i).Value = 848 Then
Range(.Cells(i, 2), .Cells(i, 14)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Select
Selection.PasteSpecial
End If
Next i
End With
EDIT:
Ok, I'm sure this is frowned upon, but this is how I would have solved the issue. It's nothing close to pro-code, but it gets the work done.
Range("A1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = 848 Then
Range(ActiveCell.Offset(0, 1).Address(False, False), ActiveCell.Offset(0, 14).Address(False, False)).Select
Selection.Copy
Workbooks("destination.xlsx").Activate
Worksheets("Sheet1").Select
Range("A63976").Select
Selection.PasteSpecial
End If
ActiveCell.Offset(1, 0).Select
Loop
If this code does not work, there's something else that's fishy. The code needs to be executed in the worksheet containing the list, which should be placed in column A and contain no blanks.
You can always change which sheet is selected by adding code.