I have two sheets (sheet 1 and sheet 2). Sheet1 is a subset of sheet2. I have written a macro that compares the headers of two sheets and then if matches, copy all the contents from Sheet 1 to sheet 2.
The next requirement is, I have a key column in Sheet1, I now need to paste the contents of sheet 1 to sheet 2, sheet3, sheet 4 based on the key column values.
Please find attached the screenshot for details and also please find the code which I have written by taking the help of you guys in the Stack-overflow.
I am new to this and need your help. Image.Please Click
Code:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim lastrow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS , desWS1 As Worksheet
Set srcWS = Sheets("Sheet1")
Set desWS1 = Sheets("Sheet2")
lastrow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = desWS1.Cells(1, Columns.count).End(xlToLeft).Column
For Each header In desWS1.Range(desWS1.Cells(1, 1), desWS1.Cells(1, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(lastrow, foundHeader.Column)).Copy desWS1.Cells(1, header.Column)
End If
Next header
lCol = desWS2.Cells(1, Columns.count).End(xlToLeft).Column
**' I am stuck here. Unable to think beyond these two lines after applying the filter**
**Sheets("Sheet1").Cells(1, 1).AutoFilter Field:=7, Criteria1:="Yellow"
Sheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).Select**
For Each header In desWS2.Range(desWS2.Cells(1, 1), desWS2.Cells(1, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(lastrow, foundHeader.Column)).Copy desWS2.Cells(1, header.Column)
End If
Next header
Application.ScreenUpdating = True
End Sub
Many thanks for your time and assistance.
Not my work so won't even pretend, but have you tried this?
Credit: https://www.excelcampus.com/vba/copy-paste-cells-vba-macros/
Sub Range_Copy_Examples()
'Use the Range.Copy method for a simple copy/paste
'The Range.Copy Method - Copy & Paste with 1 line
Range("A1").Copy Range("C1")
Range("A1:A3").Copy Range("D1:D3")
Range("A1:A3").Copy Range("D1")
'Range.Copy to other worksheets
Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("A1")
'Range.Copy to other workbooks
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy _
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
Sub Paste_Values_Examples()
'Set the cells' values equal to another to paste values
'Set a cell's value equal to another cell's value
Range("C1").Value = Range("A1").Value
Range("D1:D3").Value = Range("A1:A3").Value
'Set values between worksheets
Worksheets("Sheet2").Range("A1").Value = Worksheets("Sheet1").Range("A1").Value
'Set values between workbooks
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value
End Sub
Essentially you trying to do a vlookup it sounds like. This site has helped me in the past as well.
https://powerspreadsheets.com/excel-vba-vlookup/
VLookupResult = WorksheetFunction.vlookup(LookupValue, Worksheet.TableArray, ColumnIndex, False)
Related
I have a constant task at work where I need to copy a list of numbers to another sheet. In that sheet, I need to paste those numbers one by one, in a cell to the right of cells with a certain value(that repeats in a column). (notice that the target table is sorted by that value -"מודל תגובה" and there are hidden rows.
It's hard to explain so I hope the images will do.
I tried to write suitable code but I kept getting different errors.
It seems that problems occur when copying the cell values to the target cells.
Dim i As Integer
i = 4
Do While IsEmpty(Cells(i, 1).Value) = False
Worksheets(1).Select
Cells(i, 1).Copy
Worksheets(2).Select
Cells.Find(What:="מודל תגובה", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Activate
If IsEmpty(ActiveCell.Value) = False Then
Selection.FindNext(After:=ActiveCell).Activate
ActiveCell.Offset(0, -1).Paste
Else
ActiveCell.Offset(0, -1).Select
ActiveCell.Paste
End If
i = i + 1
Loop
sorry for the shitty code(literally my first macro).
The solution would be to loop through the visible cells of the filtered range only.
Make sure the destination is filtered for "מודל תגובה" before running this code. It needs to look like your second image before running this code.
Dim SourceSheet As Worksheet
Set SourceSheet = Worksheets(1)
Dim DestinationSheet As Worksheet
Set DestinationSheet = Worksheets(2)
Dim LastRow As Long
LastRow = DestinationSheet.Cells(DestinationSheet.Rows.Count, "B").End(xlUp).Row
Dim VisibleCells As Range
On Error Resume Next 'next line errors if no visible cells so we turn error reporting off
Set VisibleCells = DestinationSheet.Range("A2", "A" & LastRow).SpecialCells(xlCellTypeVisible)
On Error Goto 0 'turn error reporting on or you won't see if other errors occur
If VisibleCells Is Nothing Then 'abort if no cells are visible in the filter
MsgBox "No cells to paste at"
Exit Sub
End If
Dim SourceRow As Long
SourceRow = 4 'start row in your source sheet
Dim Cell As Range
For Each Cell In VisibleCells.Cells 'loop through visible cells
Cell.Value = SourceSheet.Cells(SourceRow, "A").Value 'copy value
SourceRow = SourceRow + 1 'incerease source row
Next Cell
Make sure to define DestinationSheet and SourceSheet with your sheets names.
Try this:
Dim i As Integer
Dim Last_Row as Long
Worksheets(1).Select
'The "1" Of the line below means that the variable gonna count the rows of the first column (A)
Last_Row = Application.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:A" & Last_Row).Copy
Worksheets(2).Select
Range("A1").Select
ActiveSheet.Paste
I am brand new to VBA coding and am confused on how I would be able to copy and paste values from one sheet to another if two criteria points are met. In the sheet below I want to copy "12, 9, and 15" and paste it into the "Expected, P10 and P90" cells on sheet2 if the names on sheet one "Orange, Green" match those on sheet 1.
I've been attempting this on my own for quite some time now with now luck.
Attached is the code I started
Sub Copy_Certain_Data()
a = Worksheets("Schedule Results").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If Worksheets("Schedule Results").Cells(i, 3).Value = "NE2P1" Then
Worksheets("schedule results").Rows(i).Copy
Worksheets("Campaign 1 Data").Activate
Range("F2").Select
ActiveSheet.Paste
Worksheets("Schedule Results").Activate
End If
Next
Application.CutCopyMode = False
End Sub
Below is a basic macro to loop through two worksheets and find the row that has matching values in columns A and B. Then writing the values from the row in sheet 1, columns C:E to the row in sheet 2, columns D:F.
Dim ws1 As Worksheet, ws2 As Worksheet
Dim xCel As Range, yCel As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'change sheet names as needed
Set ws2 = ThisWorkbook.Sheets("Sheet2")
For Each xCel In ws1.Range("A2", ws1.Range("A" & ws1.Rows.Count).End(xlUp)) 'loop sheet1 column A
If xCel.Value = "Orange" And xCel.Offset(, 1).Value = "Green" Then 'when both values are found in row goto sheet2 loop
For Each yCel In ws2.Range("A2", ws2.Range("A" & ws2.Rows.Count).End(xlUp)) 'Loop sheet2 Column A
If yCel.Value = "Orange" And yCel.Offset(, 1).Value = "Green" Then 'when found write values from sheet1 to sheet2
yCel.Offset(, 3).Resize(, 3).Value = xCel.Offset(, 2).Resize(, 3).Value
End If
Next yCel
End If
Next xCel
This should give you a start to get you what you are trying to accomplished based on the code you have tried. Its always best practice to set your variables and also qualify worksheets.
Using .copy and .paste can cause issues because if the cells are not the same size you will get an error stating such and that is why I always set the destination cell value = the source cell value.
Option Explict
Sub Copy_Certain_Data()
Dim wb As Workbook
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Sheets("Schedule Results")
Set wsDest = wb.Sheets("Campaign 1 Data")
Dim LastRow As Long, i As Long
LastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
If wsSource.Cells(i, 3).Value = "NE2P1" Then
wsDest.Cells(i, 6) = wsSource.Cells(i, 3)
End If
Next i
End Sub
So, I'm looking for a way to skip specific columns in a row copy. I'm working with doing a bunch of loops to copy/paste from a bunch of sheets of variable sized reports and I want a way to simply skip a column or columns in a row copy since I can't just do a entirecolumn.delete to deal with the excess and doing a counter system might get broken. I guess what I'd like (which doesn't exist as far as I know) is something like a row copy columns 3 to 5 ignore.
Dim LastRow As Long
Dim LastCell As Range
For Each Cell In Sheet10.Range("A:B")
If Cell.Value Like "*Total*" Then
Set Mastersheet = Sheet10
Set Pastesheet = Sheet3
Cell.EntireRow.Copy
With Pastesheet
Set LastCell = Pastesheet.Cells.Find(What:="*", LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
LastRow = LastCell.Row
End If
Pastesheet.Cells(LastRow + 1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
End If
Next
Here is how i would accomplish your task, broken-down into steps.
Dim rw As Range
'Step 1: Insert helper column
Columns(3).Insert
'Step 2: If any cell in columns A or B contain the word "Total", put "1" in the helper column
For Each rw In Worksheets("Sheet10").UsedRange.Rows
If rw.Cells(1, 1).Value Like "*Total*" Or rw.Cells(1, 2).Value Like "*Total*" Then
rw.Cells(1, 3).Value = "1"
End If
Next
'Step 3: Filter using the helper column, hide the helper column and 3 other columns, copy(offset removes header row), paste to sheet3 lastrow +1
With Range("A1").CurrentRegion
.AutoFilter Field:=3, Criteria1:="1"
.Columns("C:F").Hidden = True
.Offset(1).SpecialCells(xlVisible).Copy Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
'Step 4: Clean up Sheet10, or macro will not work next time
With Sheet10
.AutoFilterMode = False
.Columns.Hidden = False
.Rows.Hidden = False
.Columns(3).Delete
End With
I have a row of dynamic column headers in the "Summary" tab and 111 worksheets appended at the end of the workbook, although this number is subject to change. I search for each column header in each appended worksheet and copy the cell immediately beneath any match to its corresponding column and row, a new row for each appended worksheet, in the "Summary" tab. The output meets my expectations. The time necessary to loop through every appended worksheet does not. Please let me know if there are obvious ways to optimize the code or more efficiently achieve my desired results. Thanks in advance.
Sub riasummary()
Dim riawksht As Worksheet
Dim consolwksht As Worksheet
Dim c As Integer
Dim r As Long
Dim sheader As Range
Dim sheaders As Range
Dim rheader As Range
Dim rheaders As Range
c = Sheets("Summary").Cells(1, Columns.Count).End(xlToLeft).Column
Set sheaders = Sheets("Summary").Range(Cells(1, 1), Cells(1, c))
For Each riawksht In ActiveWorkbook.Worksheets
If riawksht.Name <> "Summary" Then
Set rheaders = riawksht.Range("a5:xfd12")
For Each rheader In rheaders
For Each sheader In sheaders
r = Sheets("Summary").Cells(Rows.Count, "a").End(xlUp).Row
If rheader.Value = sheader.Value Then
rheader.Offset(1, 0).Copy
sheader.Offset(r, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
'sheader.Offset(1, 0).Value = rheader.Offset(1, 0).Value
End If
Next
Next
End If
Next
End Sub
As a tangent, I also occasionally return an "Application-defined or object-defined error" at the following line of code that I cannot seem to decipher, and any insight here would be much appreciated as well.
Set sheaders = Sheets("Summary").Range(Cells(1, 1), Cells(1, c))
Set sheaders = Sheets("Summary").Range(Cells(1, 1), Cells(1, c))
Should be:
With Sheets("Summary")
Set sheaders = Sheets("Summary").Range(.Cells(1, 1), .Cells(1, c))
End With
You should always avoid unqualified Cells or Range calls, since they will default (in a regular module) to the active sheet.
I need to scan through all of the rows in the "Master" worksheet, find any cells with the value "Shipped" in the column "Status", then cut and paste each entire row to another sheet. The pasted rows need to be placed after the last row also.
I found this post (pasted below) which I slightly modified to delete rows successfully. But I can not figure out how to move rows instead. Should I try an entirely new method?
Sub DeleteRows()
Dim rng As Range
Dim counter As Long, numRows as long
With ActiveSheet
Set rng = Application.Intersect(.UsedRange, .Range("C:C"))
End With
numRows = rng.Rows.Count
For counter = numRows to 1 Step -1
If Not rng.Cells(counter) Like "AA*" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
End Sub
I do not know VBA. I only kind of understand it because of my brief programming history. I hope that is okay and thank you for any help.
There's a couple of ways you could do it, can you add a filter to the top columns, filter by the value of 'Shipped'? Does it need to be copy and pasted into a new sheet?
It's not the most concise code but it might work
sub Shipped_filter()
dim wsSheet as worksheet
dim wsOutputSheet as worksheet
dim BottomRow as integer
Set wsSheet = worksheets("Sheet1") 'change to the sheet name
set wsOutputSheet = worksheets("Sheet2") 'change to the sheet name
'*****************************
'* Delete old data on Sheet2 *
'*****************************
wsoutputsheet.activate
Activesheet.cells.clearall
wsSheet.range("A1").select
selection.autofilter
BottomRow = wsSheet.range("A90000").end(xlup).row ' or another column you guarantee will always have a value
activesheet.range("$A$1:$Z$"&BottomRow).AutoFilter field:=1, Criteria1:="Shipped" ' change field to whatever column number Status is in
'********************************
'* Error trap in case no update *
'********************************
if activesheet.range("A90000").end(xlup).row = 1 then
msgbox("Nothing to ship")
exit sub
end if
wsSheet.range("A1:Z"&Bottomrow).select
selection.copy
wsOutputSheet.range("A1").select
selection.pastespecial Paste:=xlpastevalues
application.cutcopymode = false
msgbox('update complete')
end sub
I haven't tried it so it might need updating
I ended up combining the code I was originally using (found here) with an AutoFilter macro (found here). This is probably not the most efficient way but it works for now. If anyone knows how I can use only the For Loop or only the AutoFilter method that would be great. Here is my code. Any edits I should make?
Sub DeleteShipped()
Dim lastrow As Long
Dim rng As Range
Dim counter As Long, numRows As Long
With Sheets("Master")
'Check for any rows with shipped
If .Range("R:R").Find("Shipped", , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No shipped plates found. ", , "No Rows Moved": Exit Sub
Else
Application.ScreenUpdating = False
'Copy and paste rows
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Worksheets("ShippedBackup").Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A1:U" & lastrow).AutoFilter field:=18, Criteria1:="Shipped"
.Range("A2:U" & lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("ShippedBackup").Range("A" & lastrow2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.ShowAllData
'Delete rows with shipped status
Set rng = Application.Intersect(.UsedRange, .Range("R:R"))
numRows = rng.Rows.Count
For counter = numRows To 1 Step -1
If rng.Cells(counter) Like "Shipped" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
MsgBox "All shipped records have been moved to the ""ShippedBackup"" worksheet.", , "Backup Complete"
End If
End With
Hope it helps someone!