I used the Recorder to create this small macro... now I just need it to work with variable numbers of row (instead of my row 20000 cheat).
Is there a tip or a trick that can tell this code to stop at the last row?
Columns("K:K").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("K1").Select
ActiveCell.FormulaR1C1 = "Total"
Range("K2").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-2]-RC[-3]-RC[-1],""h:mm"")"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K20000")
Range("K2:K20000").Select
Thanks
You could try something like this.
Sub LastRow()
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ActiveSheet
LastRow = sht.Cells(sht.Rows.Count, "K").End(xlUp).Row
End Sub
Since you want to fill down in column K, I assume that this column is empty below the cell K2. Another column probably has data and you want to fill down as far as that other column's last row of data.
To do that, you can determine the last row in that other column, in my example, it's column A, but you can change that. Then plug the variable lastRow into your AutoFill statement.
Dim sht As Worksheet
Dim lastRow As Long
Set sht = ActiveSheet
lastRow = sht.Cells(Rows.Count, "A").End(xlUp).Row
sht.Range("K1").FormulaR1C1 = "Total"
sht.Range("K2").FormulaR1C1 = "=TEXT(RC[-2]-RC[-3]-RC[-1],""h:mm"")"
sht.Range("K2").AutoFill Destination:=sht.Range("K2:K" & lastRow)
Assuming you have your last row in column A:
Columns("K:K").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("K1").Select
ActiveCell.FormulaR1C1 = "Total"
Range("K2").Select
ActiveCell.FormulaR1C1 = "=TEXT(RC[-2]-RC[-3]-RC[-1],""h:mm"")"
Range("K2").Select
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Selection.AutoFill Destination:=Range("K2:K" & LastRow)
Range("K2:K" & LastRow).Select
Related
I currently have code that inserts two columns, and copies values from two other columns into these two new columns.
'Insert 2 Column to the Left of S
Columns("S:T").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeft
'Copy Column J into Column S
Columns("J:J").Select
Selection.Copy
Columns("S:S").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlFormats
'Copy Column Q into Column T
Columns("Q:Q").Select
Selection.Copy
Columns("T:T").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlFormats
However, I want to change it so that the value in Column J is only copied IF the value next to it in Column I is not "DoNotCopy" (or another specific text).
I know, as a workaround, I could insert another column and have an IF statement to only show the value if blah blah... and copy that column value over instead. But this is not as "pretty" as VBA doing the work. Or would you disagree, and this is the better way to do it?
Insert Column and Copy Conditionally to It
Sub InsertData()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.UsedRange
With Intersect(rg.EntireRow, ws.Columns("S:T"))
.Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Formats
Intersect(rg, ws.Columns("J")).Copy
.Columns(1).Offset(, -2).PasteSpecial xlPasteFormats
' Values
.Columns(1).Offset(, -2).Value = ws.Evaluate("IF(" _
& Intersect(rg, ws.Columns("I")).Address & "<>""DoNotCopy""," _
& Intersect(rg, ws.Columns("J")).Address & ","""")")
' Formats
Intersect(rg, ws.Columns("Q")).Copy
.Columns(2).Offset(, -2).PasteSpecial xlPasteFormats
' Values
.Columns(2).Offset(, -2).Value = Intersect(rg, ws.Columns("Q")).Value
Application.CutCopyMode = False
End With
End Sub
Place the IF function into your target column. This logic assumes the first row is the beginning of the data, adjust as needed.
Dim r As Range, idx As Long
'identify the last cell with a value
idx = Cells(Rows.Count, "S").End(xlUp).Row
'set the range to the target column
Set r = Range("J1:J" & idx)
'value the target column with the IF function
Cells(1, "J").Formula = "=IF(T1=""DoNotCopy"","""",S1)"
r.FillDown
r.copy
r.PasteSpecial xlPasteValues
I am a newbie and my macro is mix of recorded and written code , hence embarrassed
How Do I fill all blank cells In Column A and B with data below it as there are gaps and i am not able to fill the gaps or cannot think of any other way
Sub Macro4offsetselectionfinal()
Dim sht As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim StartCell As Range
Dim lr As Long
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Columns("C:D").Select
Selection.Copy
Columns("A:B").Select
ActiveSheet.Paste
Range("C1:E5").Select
Application.CutCopyMode = False
Selection.ClearContents
Set sht = Worksheets("00689")
Set StartCell = Range("A7")
'Find Last Row and Column
LastRow = sht.Cells(sht.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = sht.Cells(StartCell.Row, sht.Columns.Count).End(xlToLeft).Column
'Select Range
sht.Range(StartCell, sht.Cells(LastRow, LastColumn)).Select
Selection.AutoFilter Field:=5, Criteria1:="<>"
Range("A8:B8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Rows("7:7").Select
Selection.AutoFilter
Range("B7").Select
Selection.End(xlDown).Select
Selection.Offset(-1).Select
ActiveCell.FormulaR1C1 = ActiveCell.Offset(1, 0).Value
Range("A7").Select
Selection.End(xlDown).Select
Selection.Offset(-1).Select
ActiveCell.FormulaR1C1 = ActiveCell.Offset(1, 0).Value
Range("A8").Select
lr = Range("A" & Rows.Count).End(xlUp).Row
Range("A8:A" & lr).SpecialCells(xlCellTypeBlanks).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
ActiveCell.FormulaR1C1 = ActiveCell.Offset(1, 0).Formula
Application.CutCopyMode = False
Calculate
Range("A7").Select
End Sub
Using offset doesn't seem to work, can anyone advise
Thanks,
Jenny
enter image description here
If you wanted to fill the blanks with the values bellow, here is one version.
Sub FillTheBlanks()
Dim rng As Range
Set rng = Range("A7:B" & Cells(Rows.Count, "A").End(xlUp).Row)
rng.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[1]C"
rng.Value = rng.Value
End Sub
Before and after results
I am currently try to make a code that will format sheets 5 and on to module one's code and then have the program copy all the information in each of those newly formatted sheets and paste them into "sheet3" with original width and format.
I have tried the "for each" and "integer" functions but can't seem to get 'the program to move past "sheet5".
This sub is suppose to go through all of the sheets and and 'format them to my needs:
Sub TEST2()
Dim ws As Worksheet
Dim wsDest As Worksheet
Dim LastRow As Long
Set wsDest = Sheets("sheet3")
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> wsDest.Name And _
ws.Name <> "sheet1" And _
ws.Name <> "sheet2" And _
ws.Name <> "sheet4" Then
'code here
Columns.Range("A:A,B:B,H:H,I:I").Delete
Columns("A").ColumnWidth = 12
Columns("B").ColumnWidth = 17
Columns("C").ColumnWidth = 10
Columns("D").ColumnWidth = 85
Columns("E").ColumnWidth = 17
ActiveSheet.Range("D:D").WrapText = True
ActiveSheet.Range("F:F").EntireColumn.Insert
ActiveSheet.Range("F1").Formula = "Product ID"
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("F2:F" & LastRow).Formula = "=$G$2"
ActiveSheet.Range("F2").Copy
Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End If
Next ws
End Sub
This sub is meant to go to "sheet5" first and paste it into '"sheet3", than the second half of the sub should start at "sheet6" and go on 'until the end of the work sheets and then copy & paste onto "sheet3" with 'original width.
Sub Test1()
Dim sht As Worksheet
Dim LastRow As Long
Dim WS_Count As Integer
Dim I As Integer
Sheets("Sheet5").Select
Application.CutCopyMode = False
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Range("D:D").WrapText = True
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop
For I = 5 To WS_Count
'code here
Sheets("Sheet6").Select
Application.Run "PERSONAL.XLSB!Module1.Del_move_insert_colmuns"
Application.CutCopyMode = False
Range("G2").Select
ActiveCell.Offset(0, -1).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToLeft)).SelectApplication.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A1").Select
'crtl shift + down
Selection.End(xlDown).Select
'moves down one cell to paste
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Next I
End Sub
What im getting right now is it does "sheet5" and "sheet6" fine,but after that doesn't format and on sheet there all i get is a bunch of columns with top labeled as product ID and a bunch of 0's.
A big part of your problem is that most of your code is "assuming" that you are working with a certain worksheet when you're really working with the ActiveSheet. As an example in your TEST2 routine, you're looping through all of the worksheets in the workbook, skipping certain sheets. This part works fine. But when you want to format the other sheets, you're really only working with whatever worksheet is currently active. To fix this, you should make a habit of making sure all of your Worksheet, Range, and Cells reference are always fully qualified. So then your code works like this:
ws.Columns.Range("A:A,B:B,H:H,I:I").Delete
ws.Columns("A").ColumnWidth = 12
ws.Columns("B").ColumnWidth = 17
ws.Columns("C").ColumnWidth = 10
ws.Columns("D").ColumnWidth = 85
ws.Columns("E").ColumnWidth = 17
ws.Range("D:D").WrapText = True
ws.Range("F:F").EntireColumn.Insert
ws.Range("F1").Formula = "Product ID"
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
ws.Range("F2:F" & LastRow).Formula = "=$G$2"
ws.Range("F2").Copy
ws.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
Notice how every single reference is locked to the same worksheet. You can take a shortcut though, by using the With statement. But you must make sure that each reference has the . in front of it to lock it back to the With object, like this:
With ws
.Columns.Range("A:A,B:B,H:H,I:I").Delete
.Columns("A").ColumnWidth = 12
.Columns("B").ColumnWidth = 17
.Columns("C").ColumnWidth = 10
.Columns("D").ColumnWidth = 85
.Columns("E").ColumnWidth = 17
.Range("D:D").WrapText = True
.Range("F:F").EntireColumn.Insert
.Range("F1").Formula = "Product ID"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("F2:F" & LastRow).Formula = "=$G$2"
.Range("F2").Copy
.Range("F2:F" & LastRow).PasteSpecial Paste:=xlPasteValues
End With
For the rest of your code, you can make improvements by avoiding the use of Select and Activate. Consider also the tips discussed in this article that will give you excellent guidance.
I'm trying to stop using ActiveCell etc as StackOverflow has very much declared this a "nono"
My current code is:
Sub SitesAndProd()
Set wb = ActiveWorkbook
Set ws = Worksheets("Data")
Set rng = ws.Cells(1, 13)
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
rng.FormulaR1C1 = "SitesAndProd" 'Rename Cell SitesAndProd
Set rng = ws.Cells(2, 13)
rng.FormulaR1C1 = "=RC[-12]&RC[-4]"
rng.Offset(0, -1).Select 'Move left 1 column
Selection.End(xlDown).Select 'Go to bottom of column
rng.Offset(0, 1).Select 'Move right 1 column
Range(Selection, Selection.End(xlUp)).Select 'Go to top of Column
Selection.FillDown 'Copy Formula Down "Fill"
Selection.Copy 'Ctrl + C
Selection.PasteSpecial xlPasteValues 'Right click + V
Application.CutCopyMode = False 'Esc (stops the crawling ants
End Sub
When using Selection.End(xlDown).Select and xlUp later - it's not saving the range position
What's the best way to make sure the range is kept here?
When using the following:
Range("M2").Select
ActiveCell.FormulaR1C1 = "=RC[-12]&RC[-4]"
Range("M2").Select
ActiveCell.Offset(0, -1).Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
The code will pull the correct form - going left 1, to the bottom, right 1, selecting up to to the, then copying down
Any chance that someone can point me in the right direction to be able to do this without ActiveCell, Selection and Select?
This is supposing the LastRow you calculated on column A equals the same amount of rows in column M
Option Explicit
Sub SitesAndProd()
Dim wb As Workbook, ws As Worksheet, LastRow As Long
Set wb = ThisWorkbook
Set ws = Worksheets("Data")
ws.Cells(1, 13) = "SitesAndProd"
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
With ws.Range(ws.Cells(2, 13), ws.Cells(LastRow, 13))
.FormulaR1C1 = "=RC[-12]&RC[-4]"
.Value = .Value
End With
End Sub
I've tweaked some of your code. You need to declare your variables, wb As Workbook and ws As Worksheet. If workbook is the one you got your code in, use ThisWorkbook instead ActiveWorkbook you will get less errors from that.
Edit: Try to avoid as much the global variables. Pass them on your subs or functions as variables.
I expect your code:
Range("M2").Select
ActiveCell.FormulaR1C1 = "=RC[-12]&RC[-4]"
Range("M2").Select
ActiveCell.Offset(0, -1).Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
can be replaced with:
Range(Range("M2"), Range("M" & ActiveSheet.Rows.Count).End(xlUp)).Formula = "=RC[-12]&RC[-4]"
If the column which you would like to use to determine the last filled cell is column Q:
Range(Range("M2"), Range("Q" & ActiveSheet.Rows.Count).End(xlUp).Row).Formula = "=RC[-12]&RC[-4]"
I am trying to copy the formula from a cell in column C straight across to column F. I always want to copy the formula from column C and drag through column F, however the row should be determined by the active cell. Once the formula is dragged across I want to drag those formulas down to the last row with data in column B.
So far my VBA from my recorded macro looks like this:
ActiveCell.FormulaR1C1 = _
"=INDEX('Item Setup'!C2:C40,MATCH(R[-8]C2,'Item Setup'!C2,0),MATCH(R4C,'Item Setup'!R4C2:R4C40,0))"
Range("C13").Select
Selection.AutoFill Destination:=Range("C13:F13"), Type:=xlFillDefault
Dim lastRow As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("C13:F13").AutoFill Destination:=Range("C13:F" & lastRow)
Range("C13:F13").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Think you can do this in one go, and also without having to use Select or Autofill.
Not generally advisable though to base a macro on the active cell.
Sub x()
Dim lastRow As Long
lastRow = Range("B" & Rows.Count).End(xlUp).Row
With Range(Cells(ActiveCell.Row, "C"), Cells(lastRow, "F"))
.FormulaR1C1 = _
"=INDEX('Item Setup'!C2:C40,MATCH(R[-8]C2,'Item Setup'!C2,0),MATCH(R4C,'Item Setup'!R4C2:R4C40,0))"
.Value = .Value
End With
End Sub
First, stay away from ActiveCell, Selection and Select, instead use fully qualified Range and Worksheet objects.
Second, you can set your entire range where you want to add your formula, and then fill it at once, without dragging or anything like it.
Modified Code
Dim Sht As Worksheet
Dim AnchorRng As Range
Dim LastRow As Long
Set Sht = ThisWorkbook.Sheets("YourSheetName") ' modify with your sheet's name
With Sht
Set AnchorRng = ActiveCell ' .Range("C13") ' start point of your formula
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row ' get last row in column B
.Range(AnchorRng, .Cells(LastRow, "F")).FormulaR1C1 = _
"=INDEX('Item Setup'!C2:C40,MATCH(R[-8]C2,'Item Setup'!C2,0),MATCH(R4C,'Item Setup'!R4C2:R4C40,0))"
End With
Note: this code is not debugging your formula, just assigning to your entire range.