I have to apply a formula in column S (=concatenate(p1,q2,r3). This formula has to copy down until column end.
ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-3],RC[-2],RC[-1])"
Range("S1").Select
Selection.copy
Range("S:S").Select
ActiveSheet.Paste
Application.CutCopyMode = False
You do not want the formula all the way to the bottom of column S; you only need it to the last used cell in columns P, Q and R.
dim lr as long
with worksheets("sheet1")
lr = application.max(.cells(.rows.count, "P").end(xlup).row, _
.cells(.rows.count, "Q").end(xlup).row, _
.cells(.rows.count, "R").end(xlup).row)
.range(.cells(1, "S"), .cells(lr, "S")).FormulaR1C1 = "=CONCATENATE(RC[-3], RC[-2], RC[-1])"
end with
Related
Straight to the point:
I am trying to match A2 on sheet "PRD" to A2 on sheet "CRD", if this is a match I want to compare B2 on sheet PRD to B2 on sheet CRD and then A3 same thing on and on to the end of the range. If there is no match between cells in column A I am trying to copy the whole row to a third sheet, if there is a match between cells in A but there is not a match between cells in B I am trying to copy the row to a third sheet.
I am stuck, I think after hours of looking at the code and Googling, not being able to check column B... I seem to be able to check, copy and paste cells that do not match contents in column A fine.
I hope I am asking the right questions and am clear, thanks for any help!!
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Dim cell As Range
Dim cell2 As Range
Dim lastrow As Long
'CRD date
With ThisWorkbook.Worksheets("CRD")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set r1 = .Range("A2:A" & lastrow)
End With
'CRD quantity
With ThisWorkbook.Worksheets("CRD")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set r3 = .Range("B2:B" & lastrow)
End With
'PRD date
With ThisWorkbook.Worksheets("PRD")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set r2 = .Range("A2:A" & lastrow)
End With
'PRD quantity
With ThisWorkbook.Worksheets("PRD")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set r4 = .Range("B2:B" & lastrow)
End With
'match PRD date to CRD date: output "Found" for record, or copy/paste onto report page
Range("A2").Select
For Each cell In r1
If IsError(Application.Match(cell, r2, 0)) Then
'select active cell's row and copy, pasting in report page
Rows(ActiveCell.Row).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRD").Select
Application.CutCopyMode = False
'if no error check quantity(B) of same cell, if match continue, if no match copy
ElseIf IsError(Application.Match(r3, r4, 0)) Then
For Each cell2 In r3
Rows(ActiveCell.Row).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CRD").Select
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
Application.CutCopyMode = False
Next
Else
End If
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
Next
End Sub
Your code relies too much on Select, ActiveCell, Selection and Activate, you should avoid all these Selecting and use fully qualified objects instead.
See the code below, and explanations inside the code's comments.
Modified Code
Option Explicit
Sub Match2Columns()
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim r4 As Range
Dim cell As Range
Dim cell2 As Range
Dim lastrow As Long
'CRD date
With ThisWorkbook.Worksheets("CRD")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set r1 = .Range("A2:A" & lastrow)
End With
'CRD quantity
With ThisWorkbook.Worksheets("CRD")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set r3 = .Range("B2:B" & lastrow)
End With
'PRD date
With ThisWorkbook.Worksheets("PRD")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set r2 = .Range("A2:A" & lastrow)
End With
'PRD quantity
With ThisWorkbook.Worksheets("PRD")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set r4 = .Range("B2:B" & lastrow)
End With
Dim PasteRow As Long ' row to paste at "sheet1"
'match PRD date to CRD date: output "Found" for record, or copy/paste onto report page
With ThisWorkbook.Worksheets("CRD") ' <-- make sure you are looping and copying from "CRD" sheet
For Each cell In r1
If IsError(Application.Match(cell, r2, 0)) Then
' select active cell's row and copy, pasting in report page
.Rows(cell.Row).Copy
' get last empty row and add 1 row where to paste
PasteRow = Sheets("Sheet1").Range("A1").End(xlDown).Row + 1
' paste action
Sheets("Sheet1").Range("A" & PasteRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'if no error check quantity(B) of same cell, if match continue, if no match copy
ElseIf IsError(Application.Match(r3, r4, 0)) Then
For Each cell2 In r3
' select active cell's row and copy, pasting in report page
.Rows(cell2.Row).Copy
' get last empty row and add 1 row where to paste
PasteRow = Sheets("Sheet1").Range("A1").End(xlDown).Row + 1
' paste action
Sheets("Sheet1").Range("A" & PasteRow).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Next cell2
Else
' you are doing nothing here, not sure why you need it ???
End If
Next cell
End With
End Sub
I have a spreadsheet with a column of values that I would like to divide by a fixed cell (say C3), and have the results in an adjacent column.
I would like this code to run to the last available row (with values) as well.
Would greatly appreciate any help! Thanks!
If your source values were in, for instance, A1:A7 and you want to copy them to B1:B7 and divide by C3 at the same time, you could:
With ActiveSheet
'Determine last row
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Copy the original values from column A to column B
.Range("B1:B" & lastRow).Value = .Range("A1:A" & lastRow).Value
'Copy / Pastespecial Divide using cell C3
.Range("C3").Copy
.Range("B1:B" & lastRow).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlDivide, _
SkipBlanks:=False, _
Transpose:=False
Application.CutCopyMode = False
End With
You can use Do While
Do While Cells(iCol, 3).Value <> ""
'Do some thing
iCol = iCol + 1
Loop
currently I have this on Sheet2
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A1001")
Range("A2:A1001").Select
Range("B2").Select
Selection.AutoFill Destination:=Range("B2:B1001")
Range("B2:B1001").Select
Range("C2").Select
Selection.AutoFill Destination:=Range("C2:C1001")
Range("C2:C1001").Select
Range("D2").Select
Selection.AutoFill Destination:=Range("D2:D1001")
Range("D2:D1001").Select
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E1001")
Range("E2:E1001").Select
Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G1001")
Range("G2:G1001").Select
Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H1001")
Range("H2:H1001").Select
Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I1001")
Range("I2:I1001").Select
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J1001")
Range("J2:J1001").Select
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K1001")
Range("K2:K1001").Select
Instead of having the destination range A2 to A1001 I want to have A2 to the same last row as sheet1 e.g if in sheet1 the last row is row 147 I want the code to fill down Selection.AutoFill Destination:=Range("A2:A147")
I do not know how to accomplish this.
Thanks
This should work for you...
Sub LastRowAutofill()
On Error Resume Next
Dim wsSheet1 As Worksheet: Set wsSheet1 = Worksheets("Sheet1")
Dim LastRow As Long
LastRow = wsSheet1.Columns(1).Find("*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Dim i As Long
With Worksheets("Sheet2")
For i = 1 To 11
If i <> 6 Then .Cells(2, i).AutoFill Destination:=.Range(.Cells(2, i), .Cells(LastRow, i))
Next i
End With
End Sub
Or you can use the following if you want the last row in the entirety of sheet1:
LastRow = wsSheet1.UsedRange.Find("*", LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Assuming your original data is on Sheet1 and you are copying to Sheet2, here's how you would do it:
Dim intLastrow As Integer
intLastrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet2").Range("A2").Select
Selection.AutoFill Destination:=Range(cells(2,"A"),cells(intLastrow, "A"))
Sheets("Sheet2").Range(Cells(2, "A"), Cells(intLastrow, "A")).Select
intLastrow = Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
Sheets("Sheet2").Range("B2").Select
Selection.AutoFill Destination:=Range(cells(2,"B"),cells(intLastrow, "B"))
Sheets("Sheet2").Range(Cells(2, "B"), Cells(intLastrow, "B")).Select
I have a column of IDs in an Excel worksheet called Sheet1. I have data that corresponds to the IDs in columns to the right of Column A. The amount of cells in a row varies. For example:
A, B, C, D, E, F, ...
John, 5, 10, 15, 20
Jacob, 2, 3
Jingleheimmer, 5, 10, 11
I'm trying to copy that data into a new worksheet, Sheet5, in the following format:
A, B, C, D, E, F, ...
John, 5
John, 10
John, 15
John, 20
Jacob, 2
Jacob, 3
Jingleheimmer, 5
Jingleheimmer, 10
Jingleheimmer, 11
I wrote the following code that copies over the first two IDs. I could continue to copy paste the second half of the code and just change the cells, however, I have 100s of IDs. This would take too long. I think whenever a process is repeated I should be using a loop. Can you help me turn this repetitive code into a loop?
Sub Macro5()
Dim LastRowA As Integer
Dim LastRowB As Integer
''' Process of copying over first ID '''
'grab all data cells in B2 to the right
With Sheets("Sheet1").Select
Range("B2", Range("B2").End(xlToRight)).Select
Selection.Copy
End With
'paste that data into the first empty cell of Column B in Sheet5
With Sheets("Sheet5").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End With
'grab the corresponding ID in cell A2
With Sheets("Sheet1").Select
Range("A2").Select
Application.CutCopyMode = False
Selection.Copy
End With
'paste the corresponding ID into the first empty cell of Column A in Sheet5
With Sheets("Sheet5").Select
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("A1:A" & LastRowB)
End With
''' Repeat that process for each row in Sheet1 '''
'grab all data cells in B3 to the right
With Sheets("Sheet1").Select
Range("B3", Range("B3").End(xlToRight)).Select
Selection.Copy
End With
'paste that data into the first empty cell of Column B in Sheet5
With Sheets("Sheet5").Select
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & LastRowB + 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
End With
'grab the corresponding ID in cell A3
With Sheets("Sheet1").Select
Range("A3").Select
Application.CutCopyMode = False
Selection.Copy
End With
'paste the corresponding ID into the first empty cell of column A in Sheet5
'and autofill down to the last populated cell in column B
With Sheets("Sheet5").Select
LastRowA = Cells(Rows.Count, "A").End(xlUp).Row + 1
Range("A" & LastRowB + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
Selection.AutoFill Destination:=Range("A" & LastRowA & ":A" & LastRowB)
End With
End Sub
Try this:
Sub test()
Dim i As Integer
Dim j As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim nRow As Integer
Dim lRow As Integer
Dim lCol As Integer
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet5")
nRow = 1
With ws1
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow
lCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
For j = 2 To lCol
ws2.Cells(nRow, 1).Value = .Cells(i, 1).Value
ws2.Cells(nRow, 2).Value = .Cells(i, j).Value
nRow = nRow + 1
Next j
Next i
End With
End Sub
It runs through each row in the sheet one at a time, copying over the names and associated numbers up through the last column with values in that row. Should work very quickly and doesn't require constant copy & pasting.
This should do what you're looking for.
Sub test()
Dim lastrow As Long, lastcol As Long
Dim i As Integer, j as Integer, x as Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet5")
lastrow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
x = 1
With ws1
For i = 1 To lastrow
lastcol = .Cells(i, .Columns.Count).End(xlToLeft).Column
For j = 2 To lastcol
ws2.Cells(x, 1).Value = .Cells(i, 1).Value
ws2.Cells(x, 2).Value = .Cells(i, j).Value
x = x + 1
Next j
Next i
End With
End Sub
I am having trouble being able to copy the last two columns with data in a worksheet and then insert the same columns to the left of them. Here is my code so far, it copies the correct columns but it just pastes them to the right.
Sub GlobalPerformNewMonths()
Dim lngLastRow As Long
With ThisWorkbook.Worksheets("Global Supplier Performance")
lngLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Cells(1, .Columns.Count).End(xlToLeft).Offset(,Resize(lngLastRow,Copy .Cells(1, .Columns.Count).End(xlToLeft).Offset(, -2)
Columns("D:AZ").ColumnWidth = 18.43
Application.CutCopyMode = False
End With
End Sub
Try selecting the entire columns of the data you want. Select them and then insert them to the left of the desired column.
Range("d:e").Select
Selection.Copy
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
You will have to shift from the last column found and Range.Resize to the appropropriate cells. To that end, I would suggest working with the Range.Cells property where numerically specific addressing is used.
Sub GlobalPerformNewMonths()
Dim lr As Long, lc As Long
With ThisWorkbook.Worksheets("Global Supplier Performance")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
lc = .Cells(1, Columns.Count).End(xlToLeft).Column
With .Cells(1, lc - 1).Resize(lr, 2)
.Copy
.Insert Shift:=xlToRight
End With
.Columns("D:AZ").ColumnWidth = 18.43
Application.CutCopyMode = False
End With
End Sub