Currently, I have columns from A to AB. I want to achieve a result such that if any cell is updated in Columns Y:AB of a row, the cells (Column A and Y:AB of a row) will be copied and pasted into a new sheet called Sheet2 into columns A to E.
My code currently can do the above but when I change all 4 values one by one in Columns Y to AB, 4 rows will be generated reflecting each change that was made. E.g. First row to be copied reflects the change made in Column Y. Second row copied reflects the change made in Column Z. Third row copied reflects the change made in Column AB. And so on.
I just need one row copied onto Sheet 2 that reflects all changes made in Columns Y to AB of a row in Sheet 1. Is there a way to do so?
I am not familiar with VBA and all guidance are much appreciated! Thank you
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns("Y:AB")) Is Nothing Then Exit Sub
Range("Y" & Target.Row, "AB" & Target.Row).Copy Sheets("Sheet2").Range("B" & Rows.count).End(xlUp).Offset(1, 0)
Range("A" & Target.Row).Copy Sheets("Sheet2").Range("A" & Rows.count).End(xlUp).Offset(1, 0)
End Sub
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo halt
Application.EnableEvents = False
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")
With sh1
If Intersect(Target, .Range("Y:AB")) Is Nothing Then GoTo forward
Dim trow As Long, drow As Long, rng As Range
trow = Target.Row
Set rng = sh2.Range("A:A").Find(.Range("A" & trow).Value, sh2.Range("A1"))
If rng Is Nothing Then
drow = sh2.Range("A" & .Rows.Count).End(xlUp).Row + 1
sh2.Range("A" & drow) = .Range("A" & trow)
Else
drow = rng.Row
End If
.Range("Y" & trow, "AB" & trow).Copy sh2.Range("B" & drow)
End With
forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume forward
End Sub
I assumed Column A contains unique identifier.
So above code does what you describe and what you explained in your comment. HTH.
Related
In my scenario I have four columns, columns A-D. If column B contains any value whatsoever then the matching row in column A must be updated to contain a predetermined value. The same macro is applied for columns C and D. I have code right now that achieves that result:
Sub Update_Column_Based_On_Column_Value1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).Formula = "=If(B1<>"""",""PREDETERMINED VALUE"","""")"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End Sub
When column B contains a value the macro will write "PREDETERMINED VALUE" in the corresponding cell in column A.
An issue occurs when a column does not contain any values at all. What happens is the macro will write my new value to nearly all of the blank cells in the entire data-set.
Thank you in advance for your time! I apologize if my question is noobish, I am still very new to VBA.
The use of If WorksheetFunction.CountA(ws.Range("B:B")) = 1 in the comment section to avoid the problem is a good attempt but there can be exceptions as discussed below. Test it several times using various scenarios (especially using blank range) to see if you are getting the desired result every single time.
.SpecialCells attempts to simplify the codes, however sometime the .SpecialCells(xlCellTypeBlanks) VBA function does not work as expected in Excel.
Also, the statement On Error Resume Next shouldn't be used as far as practicable. But if you must, be sure to insert the On Error GoTo 0 statement ASAP as you don't want to mask other errors.
Instead of .SpecialCells, you may use For Each loop to avoid this problem. So let's see how it looks:
Sub Update_Column_Based_On_Column_Value1()
Dim ws As Worksheet, lRow As Long, r As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
For Each r In .Range("A1:A" & lRow)
If IsEmpty(r) Then
r.Formula = "=If(B" & r.Row & "<>"""",""PREDETERMINED VALUE"","""")"
r = r.Value
End If
Next
End With
End Sub
Here is the answer everyone!
Sub Update_Column_Based_On_Column_Value_1()
On Error Resume Next
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
If WorksheetFunction.CountA(ws.Range("B:B")) = 1 Then
Else
With ws
lRow = .Range("B" & .Rows.Count).End(xlUp).Row
.Range("A1:A" & lRow).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=If(LEN(RC2),""NEW TEXT HERE"", TEXT(,))"
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
End If
End Sub
I have a worksheet comprising of two columns (A and B) ... the first of which is just a name, the second is a number.
If I make an edit to a number in column B, I want Excel to automatically copy that entire row to a second worksheet in order to create a list of edits that I have made.
The second worksheet would then be a continually updated list of changes that I have made to the first sheet, with the latest change (a copy of the two updated columns) added to the next unused row.
I hope that a bit of VBA trickery might be able to make this happen, but require some help to make it happen.
Try this in the sheet where you have data (under the Excel Objects), e.g Sheet1
Option Explicit
Dim PrevVal As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then
Application.ScreenUpdating = False
Dim rng As Range
Dim copyVal As String
Set rng = Nothing
Set rng = Range("A" & Target.Row & ":B" & Target.Row)
'copy the values
With Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0).Resize(1, rng.Cells.Count).Value = rng.Value
With Worksheets("Sheet1")
Range("A" & Target.Row).Copy
copyVal = CStr(PrevVal)
End With
.Offset(1, 0).PasteSpecial xlPasteFormats
.Offset(1, 1) = copyVal
Application.CutCopyMode = False
End With
End If
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Rows.Count > 1 Then Exit Sub
If Target.Columns.Count > 1 Then Exit Sub
PrevVal = Target.Value
End Sub
Here is some additional code to check the row number, as per the above answer and comments.
Dim row_num As Long
row_num = Cells(Rows.Count, "B").End(xlUp).Row
If row_num > 1 then row_num = row_num + 1 'Add 1 only when row number doesn't equal to 1, otherwise - 1.
I hope you are all well.
I am trying to use the below code to add orders of different products together. but only products with a value greater than 0 in column D. Unfortunately though the code for some reason is only copying the first row of the range, even though there are other rows which meet the criteria. can anyone help?
Sub ADDTOORDERS()
Dim Sh As Worksheet, C As Worksheet, Last As Long
Set Sh = Sheets("Menu")
Set C = Sheets("LensOrder")
With Sh
Last = .Cells(Rows.Count, 2).End(xlUp).Row
.Range("B7:D" & Last).AutoFilter Field:=2, Criteria1:=">0", Operator:=xlAnd
.Range("B7:D" & Last).SpecialCells(xlCellTypeVisible).Copy
C.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Sheets("Menu").Range("C3").Select
.Range("B7:D" & Last).AutoFilter
End With
End Sub
Made only 1 change. check this. last row thing.
Sub ADDTOORDERS()
Dim Sh As Worksheet, C As Worksheet, Last As Long
Set Sh = Sheets("Menu")
Set C = Sheets("LensOrder")
With Sh
.Range("B7:D" & Last).AutoFilter Field:=2, Criteria1:=">0", Operator:=xlAnd
Last = .range("B500000").end(xlup).row
.Range("B7:D" & Last).SpecialCells(xlCellTypeVisible).Copy
C.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial (xlPasteValues)
Sheets("Menu").Range("C3").Select
.Range("B7:D" & Last).AutoFilter
End With
End Sub
The problem with your code is that your are trying to copy the resulting range, however that range has several areas, thus it's only copying the first area.
One of the methods to work in this situation is to pass the resulted range into an array then to post the array into the desired range.
This solution assumes the header is at row 6
Try the code below:
Option Base 1 'This must be at the top of the module
Sub Add_Orders()
Dim wshSrc As Worksheet, wshTrg As Worksheet
Dim rCpy As Range, aCpy() As Variant
Dim rArea As Range, rRow As Range
Dim lRowLst As Long, lRow As Long
With ThisWorkbook
Set wshSrc = .Worksheets("Menu")
Set wshTrg = .Worksheets("LensOrder")
End With
lRowLst = wshSrc.Cells(wshSrc.Rows.Count, 2).End(xlUp).Row
'' With wshSrc.Range("B7:D" & lRowLst) 'The filter should always include the header - Replacing this line
With wshSrc.Range("B6:D" & lRowLst) 'With this line
ReDim Preserve aCpy(.Rows.Count)
.AutoFilter Field:=3, Criteria1:=">0"
Set rCpy = .Rows(1).Offset(1).Resize(-1 + .Rows.Count).SpecialCells(xlCellTypeVisible) 'Use the offset and resize to exclude the header
End With
For Each rArea In rCpy.Areas
For Each rRow In rArea.Rows
lRow = 1 + lRow
aCpy(lRow) = rRow.Value2
Next: Next
ReDim Preserve aCpy(lRow)
aCpy = WorksheetFunction.Index(aCpy, 0, 0)
With wshTrg.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Cells(1).Resize(UBound(aCpy), UBound(aCpy, 2)).Value = aCpy
End With
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
For Each...Next Statement,
Option keyword,
Range Object (Excel),
Variables & Constants,
With Statement,
Data layout: A3 onwards to A(no specific last row) is referred to as under Name Manager as =PeriodPrev.
=PeriodPrev is a label that I have used to mark the data. =PeriodCurr label starts after the last populated row for PeriodPrev.
The remaining data for PeriodPrev and PeriodCurr lay under column E to W.
Code: How to I create a clear contents of data in Columns A and E to W for data belonging to =PeriodPrev in Column A?
I've tried the following code but it does not completely serves the purpose above. "If c.Value = "PeriodPrev" Then" returns error 13. "If c.Value = Range("PeriodPrev") Then" return error 1004.
Sub BYe()
'The following code is attached to the "Clear" button which deletes Previous Period data
Dim c As Range
Dim LastRow As Long
Dim ws As Worksheet
ws = ThisWorkbook.Worksheets("Sheet1")
LastRow = Range("A" & Rows.count).End(xlUp).Row
For Each c In Range("A3:A" & LastRow)
If c.Value = "PeriodPrev" Then
' If c.Value = Range("PeriodPrev") Then
c.EntireRow.ClearContents
End If
Next c
End Sub
Use Intersect
If Not Application.Intersect(c, Range(yourLabel)) Is Nothing Then
Let me know if it doesn't work
There were a few thing wrong with that code. I've tried to address some of the problems with comments
Sub BYe()
'The following code is attached to the "Clear" button which deletes Previous Period data
Dim c As Range, lastRow As Long, ws As Worksheet
'you need to SET a range or worksheet object
Set ws = ThisWorkbook.Worksheets("Sheet1")
'you've Set ws, might as well use it
With ws
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
For Each c In .Range("A3:A" & lastRow)
'the Intersect determines if c is within PeriodPrev
If Not Intersect(c, .Range("PeriodPrev")) Is Nothing Then
'this clears columns A and E:W on the same row as c.
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "E").Resize(1, 19)).ClearContents
End If
Next c
End With
End Sub
The following should perform the same action without the loop.
Sub BYe2()
'The following code is attached to the "Clear" button which deletes Previous Period data
Dim lastRow As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
lastRow = .Range("PeriodPrev").Rows(.Range("PeriodPrev").Rows.Count).Row
.Range("A3:A" & lastRow & ",E3:W" & lastRow).ClearContents
End With
End Sub
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With