I am trying to figure out how to set the value of a range of columns on one sheet to the value of a range of columns on another sheet. I don't want to copy the entire row I only want to target specific columns as to not potentially overwrite important information inside the other cells.
Currently my code starts at the top of Sheet 1 and loops to the bottom. With each value > 0 in column 4 it searches for the identical value in column 4 of Sheet 2. If a match is found I want to copy the values from column 10-13 on x row of Sheet 1 to column 10-13 on y row of Sheet 2.
I can make this work by matching the value in each column individually but I cannot seem to find the proper method for assigning the value for a range of columns. The first line of code is what I have that currently works. The second line is what I am attempting to copy a range of column values.
ws2.Cells(y, 4).Value = ws1.Cells(x, 4).Value
ws2.Range(y, 10:13).Value = ws1.Range(x, 10:13).Value
I have tried using the Union() method but perhaps I am not sure how to implement it in this situation. Below is the rest of my code.
Sub Upload()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1LastRow As Long, ws2LastRow As Long
Dim ws1Row As Long, ws2Row As Long
Dim FindRow2 As Range
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Sheet1")
Set wb2 = Application.Workbooks.Open("Sheet Address")
Set ws2 = wb2.Worksheets("Master")
ws1LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For ws1Row = 2 To ws1LastRow
Do While ws1.Cells(ws1Row, 4) <> ""
ws2.Range("D:D").Find(What:=ws1.Cells(ws1Row, 4).Text, _
LookIn:=xlValues).Select
r = ActiveCell.Row
ws2.Cells(r, "B").Value = ws1.Cells(ws1Row, "B").Value
ws1Row = ws1Row + 1
Loop
Next
End Sub
Range.Resize(Rows, Columns)
ws2.Range("J" & y).Resize(, 3).Value = ws1.Range("J" & x).Resize(, 3).Value
Related
This is the code I have below, it works just not sure why when it copies over into the second and third column it moves down a row.
Dim shB As Worksheet, shPM As Worksheet, lastRowB As Long, lastRowPM As Long
Dim shC As Worksheet, shD As Worksheet
Dim i As Long, lastCol As Long
Dim eRow As Long
Set shB = Worksheets("Billable")
Set shPM = Worksheets("PM_Forecast")
lastRowB = Worksheets("Billable").Cells(Rows.Count, 1).End(xlUp).Row
''Loop will run from row 6 to the last row (Row 6 is the first row in table)
For i = 6 To lastRowB
''Check Billable requests first
If shB.Cells(i, 15).Value = "Detailed Estimate Submitted" Then
''Copy over ID reference
shB.Cells(i, 2).Copy
eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
shB.Paste Destination:=shPM.Cells(eRow + 1, 1)
''Copy over title
shB.Cells(i, 3).Copy
eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
shB.Paste Destination:=shPM.Cells(eRow + 1, 2)
''Copy over Effort
shB.Cells(i, 9).Copy
eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
shB.Paste Destination:=shPM.Cells(eRow + 1, 3)
End If
Next
This is a pic of the results, perhaps someone can tell me where I went wrong.
Do not calculate eRow each time (based on A:A column) when try pasting to the next columns.
Use shB.Paste Destination:=shPM.Cells(eRow , 2) (not eRow + 1) for each iteration.
Otherwise, the new added value in column A:A will add another row to eRow...
Or calculate the last row for each column:
eRow = shPM.Cells(Rows.Count, 2).End(xlUp).Row and eRow = shPM.Cells(Rows.Count, 3).End(xlUp).Row, according to the column where you intend to copy the value.
You can simplify your code using Union and placing the next empty cell variable inside the If Statement so it gets recalculate each loop.
'Define your sheet variables. `ThisWorkbook` means, the workbook in which the excel code is in.
Dim wsSrce As Worksheet: Set wsSrce = ThisWorkbook.Sheets("Billable")
Dim wsDest As Worksheet: Set wsDest = ThisWorkbook.Sheets("PM_Forecast")
'Define the last row variable in the source sheet
Dim lRowSrce As Long: lRowSrce = wsSrce.Cells(Rows.Count, 1).End(xlUp).Row
With wsSrce
For i = 6 To lRowSrce
'test each row for the data in Column O.
If .Cells(i, 15).Value = "Detailed Estimate Submitted" Then
'Define the next empty row variable in the destination sheets, within your IF statement
Dim NxtEpty As Long: NxtEpty = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
'Use Union to combine the noncontinuous ranges in each row and paste to the next empty cell in the destination sheet
Union(.Cells(i, 2), .Cells(i, 3), .Cells(i, 9)).Copy Destination:=wsDest.Cells(NxtEpty, 1)
End If
Next i
End With
I'm working with two sheets. One sheet has the full raw data while the other has a select few headers from sheet 1. If it finds a match on the header, i need it to copy the full column from sheet one to sheet 2
and it copies it to sheet 2
Here is my code so far but i can't figure out how to break the loop so that it goes through every column on sheet 1 until it finds a match:
Private Sub CommandButton1_Click()
Dim ShtOne As Worksheet, ShtTwo As Worksheet
Dim shtOneHead As Range, shtTwoHead As Range`enter code here`
Dim headerOne As Range, headerTwo As Range
Set ShtOne = Sheets("Sheet1")
Set ShtTwo = Sheets("Sheet2")
'row count
Dim b As Long
b = ShtOne.Cells(Rows.Count, 1).End(xlUp).Row
'column count in sheet 1
Dim a As Long
a = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
'column count in sheet 2
Dim c As Long
c = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Dim lastCol As Long
'get all of the headers in the first sheet, assuming in row 1
lastCol = ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtOneHead = ShtOne.Range("A1", ShtOne.Cells(1, lastCol))
'get all of the headers in second sheet, assuming in row 1
lastCol = ShtTwo.Cells(1, Columns.Count).End(xlToLeft).Column
Set shtTwoHead = ShtTwo.Range("A1", ShtTwo.Cells(1, lastCol))
'stops the visual flickering of files opening and closing - run at the background
Application.ScreenUpdating = False
'start loop from first row to last row
'For i = 1 To a
i = 1
j = 0
'actually loop through and find values
For Each headerOne In shtOneHead
j = j + 1
For Each headerTwo In shtTwoHead
'copy and paste each value
If headerTwo.Value = headerOne.Value Then
'copies one row at a time (a bit slow)
' headerOne.Offset(i, 0).Copy
' headerTwo.Offset(i, 0).PasteSpecial xlPasteAll
'copies whole rows at a time
ShtOne.Columns(i).Copy ShtTwo.Columns(j)
i = i + 1
Application.CutCopyMode = False
Exit For
End If
Next headerTwo
Next headerOne
'Next
End Sub
Assuming your headers are on row 1 for both sheets and that you will always be pasting on the second row on Sheet2.
Only loop through your column headers on the second sheet. Use Range.Find to search for each header on Sheet1. If the header is found, copy and paste accordingly
Sub Headerz()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim LC As Long, i As Long, LR As Long
Dim Found As Range
LC = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
For i = 1 To LC
Set Found = ws1.Rows(1).Find(ws2.Cells(1, i).Value)
If Not Found Is Nothing Then
LR = ws1.Cells(ws1.Rows.Count, Found.Column).End(xlUp).Row
ws1.Range(ws1.Cells(2, Found.Column), ws1.Cells(LR, Found.Column)).Copy
ws2.Cells(2, i).PasteSpecial xlPasteValues
End If
Set Found = Nothing
Next i
End Sub
All
Could any one, help me with this issue please.
I wanna to define excel VBA macro, to print several pages, each page has a different size than the others.
1st page range from cell (A1) to cell (I48)
2nd page range from cell (A50) to cell (I100)
the rest of pages from cell (A105) to cell (I3000), each one of them contains 75 rows and 9 columns.
Thanks in advance.
Sheet1 contains data.
Sheet2 contains the details of page no, start row, end row , start column, end column to print
Sub Printtest()
Dim wb As Workbook
Dim ws1, ws2 As Worksheet
Set wb = ThisWorkbook
Set ws2 = wb.Worksheets("Sheet2")
Set ws1 = wb.Worksheets("Sheet1")
Dim LastRow As Long
With ws2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To LastRow
row_start = ws2.Cells(i, 2).Value
row_end = ws2.Cells(i, 3).Value
col_start = ws2.Cells(i, 4).Value
col_end = ws2.Cells(i, 5).Value
With ws1
'ws1.Range(Cells(row_start, col_start), Cells(row_end, col_end)).PrintPreview
ws1.Range(Cells(row_start, col_start), Cells(row_end, col_end)).PrintOut
End With
Next
End Sub
I'm trying to figure out how to write compare code. I have two sheets', sheet1 and sheet2.
in sheet1 have five digits id numbers in column A, in sheet2 have same five digits id number in column C, but in sheet2 the id number is not the same row as column A in sheet1, they are differents row.
I'm trying to figure out how to make comparisons in sheet1 column A to search for a match in ANY row in sheet2 column B then copy the value from the same row in sheet2 Column C to sheet1 column D!
this is my own testing code but is not working.
Sub FindStuff()
Dim lr As Long
Dim i As Integer
lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lr
If UCase(Sheet2.Cells(1, 3).Value) = UCase(Sheet1.Cells(i, 1).Value) Then
Sheet2.Cells(14, 5).Value = Sheet1.Cells(i, 1).Offset(, 5).Value
End If
Next i
End Sub
The code you post has both syntax error and logic error, I'm not sure exactly what you are trying to do. Can you post an workbook example?
I changed your formula with Vlookup in the code, you can test and let me know if this is what you need.
Sub MatchValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long
Dim r As Long
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
lr = ws2.Cells(Rows.Count, 3).End(xlUp).Row
For r = 2 To lr
On Error Resume Next
Cells(r, 4) = WorksheetFunction.VLookup(ws2.Cells(r, 3).Value, _
ws1.Range("A:A"), 1, 0)
Next
Application.ScreenUpdating = True
End Sub
I review Stack Overflow almost daily to improve my VBA capabilities, when I find an interesting question, I try to construct a macro that will accomplish the task.
My code below does what I want, it loops through Sheet2, column "K" and searches for a match in Sheet1, column "A".
When a match is found, the code selects the cell in Sheet2, column "K", resizes 5 cells to the right and copies the range to a blank Sheet3, Column A.
To get each range to paste into a new row on Sheet3, I had to add an .Offset(1) on the Destination:= line.
Without the Offset the code just overwrites the data on row 1.
But, using the Offset the code starts writing the data on row 2.
My cheep fix was to just delete row 1.
I'm stuck, is there a way to fix my code, so it starts pasting the range of data on row 1?
Code is below;
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long
lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lRow1
For j = 1 To lRow2
If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
'The part below does what I want it to do, except it skips row 1.
'If I remove the "Offset.(1)" it just overwrites the data in row 1.
ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next j
Next i
ws3.Rows(1).Delete 'My cheep fix is to delete row 1, which is blank, to get the data to start on row 1.
End Sub
Just encase anyone want to know how I resolved my issue.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim r As Integer
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Dim lRow1 As Long, lRow2 As Long, i As Long, j As Long
lRow1 = ThisWorkbook.Sheets("Sheet2").Range("K" & Rows.Count).End(xlUp).Row
lRow2 = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
r = 1
For i = 1 To lRow1
For j = 1 To lRow2
If ws2.Cells(i, 11).Value = ws1.Cells(j, 1).Value Then
ws2.Cells(i, 11).Resize(, 5).Copy Destination:=ws3.Cells(r, 1)
r = r + 1
End If
Next j
Next i