I am trying to paste a range of formulas from one worksheet to another.
In the target worksheet, the code looks for criteria in column A, then if met, pasts in column H. It goes from the last used cell up.
I am sure this is entry level stuff but if someone can assist that would be greatly appreciated.
Code below
Sub Step8()
'Copies cells from worksheet called "Bi-Weekly"
Worksheets("Bi-Weekly").Activate
Range("H16:BK16").Copy
'Go to target worksheet called "Report"
Worksheets("Report").Activate
Dim lRow As Long
'find last row
lRow = Cells(Rows.Count, 1).End(xlUp).Row
'Loop from the last row to the first (finishing at row 17)
For i = lRow To 17 Step -1
'Where column A = "No", paste copied cells to column H (to BK) from original worksheet
If ActiveSheet.Range("A" & i).Value = "No" Then
ActiveSheet.Range("H" & i).Paste
End If
Next i
End Sub
Copy Formulas
The Code
Sub Step8()
Const cSource As String = "Bi-Weekly" ' Source Worksheet Name
Const cRange As String = "H16:BK16" ' Source Range Address
Const cTarget As String = "Report" ' Target Worksheet Name
Const cColCrit As Variant = 1 ' Target Criteria Column Letter/Number
Const cColTgt As Variant = "H" ' Target Column Letter/Number
Const cfRow As Long = 17 ' Target First Row
Const cCrit As String = "No" ' Target Criteria
Dim rng As Range ' Source Range
Dim lRow As Long ' Target Last Row Number
Dim i As Long ' Target Worksheet Row Counter
' Create a reference to the Source Range (rng).
Set rng = ThisWorkbook.Worksheets(cSource).Range(cRange)
' In Target Worksheet
With ThisWorkbook.Worksheets(cTarget)
' Calculate Last Row Number (lRow)
' from Target Criteria Column (cColCrit).
lRow = .Cells(.Rows.Count, cColCrit).End(xlUp).Row
' Loop through rows (cells) of Target Worksheet starting from First Row.
For i = cfRow To lRow
' When the cell at the intersection of the current row (i)
' and the Target Criteria Column (cColCrit) contains
' the Target Criteria (cCrit).
If .Cells(i, cColCrit).Value = cCrit Then
' Copy Source Range (rng) to the cell at the intersection
' of the current row (i) and Target Column (cColTgt).
rng.Copy .Cells(i, cColTgt)
End If
Next
End With
End Sub
No Constants Version
Sub Step8NoConstants()
Dim rng As Range ' Source Range
Dim lRow As Long ' Target Last Row Number
Dim i As Long ' Target Worksheet Row Counter
' Create a reference to the Source Range (rng).
Set rng = ThisWorkbook.Worksheets("Bi-Weekly").Range("H16:BK16")
' In Worksheet "Report".
With ThisWorkbook.Worksheets("Report")
' Calculate Last Row Number (lRow) from column 1 ("A").
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' Loop through rows (cells) of worksheet "Report" starting from row 17.
For i = 17 To lRow
' When the cell at the intersection of the current row (i)
' and column 1 ("A") contains "No".
If .Cells(i, 1).Value = "No" Then
' Copy Source Range (rng) to the cell at the intersection
' of the current row (i) and column "H".
rng.Copy .Cells(i, "H")
End If
Next
End With
End Sub
Related
I have a question regarding the below picture, I need to check until the end of the columns.
the check always begins from column "L" but the end change from file to file how needed check.
The below code work very well, still only this small issue, Your help will be appreciated
Sub HighlightInvalidRows()
Application.ScreenUpdating = False
Dim i As Long
Dim c As Long
' Prepare.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Cumulated BOM")
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
' Write the number of columns of the range to a variable ('CellsCount').
Dim CellsCount As Long: CellsCount = rg.Columns.Count
' Each row of the range has this number of columns (cells).
' Remove all range colors.
rg.Interior.Color = xlNone
' Combine the rows ('rrg') to be highlighted
' into the Highlight range ('hrg').
' Declare variables that appear for the first time in the following loop.
Dim hrg As Range
Dim rrg As Range
Dim MatchCount As Long
' Loop through the rows of the range.
For Each rrg In rg.Rows
' Write the number of appearances of the value in the current row
' to a variable ('MatchCount').
MatchCount = Application.CountIf(rrg, "-") Or Application.CountIf(rrg, "")
' Compare the match count with the cells count.
If MatchCount = CellsCount Then ' the numbers are equal
' Combine the current row into the highlight range.
If hrg Is Nothing Then ' the first match
Set hrg = rrg
Else ' all other matches
Set hrg = Union(hrg, rrg)
End If
End If
Next rrg
' Highlight the rows (in one go) and inform.
If hrg Is Nothing Then ' no matches found
MsgBox "No Empty Penetration Found.", vbInformation
Else ' matches found
hrg.Interior.Color = RGB(255, 87, 87)
End If
You define the Range with this statement:
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
You fetch the number of rows but hardcode the end column ("S").
There is a question here on SO about how to get the last used row/column/cell in Excel using VBA. Depending on the circumstances, it can get quite tricky, see Find last used cell in Excel VBA.
However, there are two things that you can easily try:
a) Simply use CurrentRegion:
Set rg = ws.Range("L2").CurrentRegion
b) The technique that is used most often to fetch the last row is the logic to "jump" to the last row and then jump back to the last row that is used. Think about as if you jump to the very end of your sheet by pressing Ctrl+Down and then pressing Ctrl+Up. Your code does already exactly that.
Similarly, you can get the last column by pressing Ctrl+Right and then pressing Ctrl+Left.
In Code this could look like that:
Dim lastRow As Long, lastCol As Long
With ws
lastRow = .Cells(.Rows.Count, "L").End(xlUp).Row ' Last row in use in Col L
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column ' Last Col in use in row 2
Set rg = .Range(.cells(2, "L"), .cells(lastRow, lastCol))
End With
Reference a Part of a (Table) Range
Note that the code is written for any range and you are having problems only with referencing the range dynamically.
There are several ways to do this but I'll stick with the easiest, most commonly used way, described in more detail in FunThomas' answer.
Replace the following lines...
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
... with these:
' In column 'L', determine the last row ('lRow'),
' the row of the bottom-most non-empty cell.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "L").End(xlUp).Row
' In row '1' (where the headers are), determine the last column ('lCol'),
' the column of the right-most non-empty cell.
Dim lCol As Long: lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("L2", ws.Cells(lRow, lCol))
I need some help. I have two columns: A and B. Column A and Column B have the following headers "Status" and "State". A filter has been applied to select "down" from a choice of "up" and "down" in Column A. When Column A is filtered some blank cells are revealed in Column B after some cells in Column B is cleared. The amount of data in the sheet varies and the position of these blanks also vary. I will like to fill down these blank cells in Column B using the values in visible cells only (not from the values in the hidden cells). Can someone help me edit this code?
In the pic above SO will fill down from 50476 to 50492 without erasing the values in the hidden cells.
Sub Filldownvisiblecells ()
Dim ws as worksheet
Dim dl as long
Dim rg as range
ws = Workbooks("Book1.xlsm"). Worksheets("Sheet1")
dl = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'Filter Column A by Down
ws.Range("A1").AutoFilter Field:=1, Criteria1:="Down"
'Clearing States in Column B (This action generates blanks that I will like to filldown from visible cells NOT hidden cells)
ws.Range("B2:B" & dl).SpecialCells(xlCellTypeVisible).Select
For Each rg In Selection.Cells
If rg.Text = "R1" Or rg.Text = "R2" Or rg.Text = "UT" Then
rg.ClearContents
End If
Next rg
'Select Filldown Range in Column B
ws.Range("B2:B" & dl). SpecialCells(xlCellTypeVisible).Select
'Filldown Blanks in Column X
For Each rg In Selection.Cells
If rg.Value = "" Then
rg.FillDown
End If
Next rg
End Sub
Fill Down With Visible Cells' Values (AutoFilter)
Option Explicit
Sub FillDownVisible()
Const wsName As String = "Sheet1"
Const fRow As Long = 1 ' First Row
Const fCol As String = "A" ' Filter Column
Const fCriteria As String = "Down" ' Filter Criteria
Const dCol As String = "B" ' Destination Column
Dim ws As Worksheet
' The Workbook Containing This Code ('ThisWorkbook')
Set ws = ThisWorkbook.Worksheets(wsName)
' An Open Workbook
'Set ws = Workbooks("Book1.xlsm").Wordksheets(wsname)
' Possibly Closed Workbook (Needs the Full File Path)
'Set ws = Workbooks.Open("C:\Test\Book1.xlsm").Worksheets(wsName)
' Clear possible previous ('active') filter.
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
' Create a reference to the Filter Range ('frg').
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCol).End(xlUp).Row
Dim frg As Range: Set frg = ws.Cells(fRow, fCol).Resize(lRow - fRow + 1)
' Create a reference to the Destination Data Range (no headers).
Dim ddrg As Range: Set ddrg = frg.EntireRow.Columns(dCol) _
.Resize(frg.Rows.Count - 1).Offset(1)
' Filter Filter Range.
frg.AutoFilter Field:=1, Criteria1:=fCriteria
' Create a reference to the Destination Range ('drg').
Dim drg As Range: Set drg = ddrg.SpecialCells(xlCellTypeVisible)
Dim dCell As Range ' Current Destination Cell
Dim pValue As Variant ' Previous Value
Dim cValue As Variant ' Current Value
' Loop through the cells of the Destination Range.
For Each dCell In drg.Cells
cValue = dCell.Value
Select Case UCase(CStr(cValue))
Case "R1", "R2", "UT", ""
dCell.Value = pValue
Case Else
pValue = cValue
End Select
Next dCell
ws.AutoFilterMode = False
End Sub
I know the "Last Row" question has already come up several times but even when looking at existing threads I cannot find what is happening. It is the first time I write a Macro so I have only been able to get to a certain point I paste the code and ask the questions later:
Option Explicit
Sub Practice()
'Last Row Searcher
Dim Sht As Worksheet
Set Sht = ActiveSheet
Dim Last_Row As Long
With Sht
Last_Row = .Range("A9999").End(xlUp).Row
End With
'Column A to D
Sheet9.Select
Range("A2:A" & Last_Row).Copy
Sheet11.Select
Range("D" & Last_Row).Select
ActiveSheet.Paste
'Column C to F
Sheet9.Select
Range("C2:C" & Last_Row).Copy
Sheet11.Select
Range("F" & Last_Row + 1).Select
ActiveSheet.Paste
'Column E to G
Sheet9.Select
Range("E2:E" & Last_Row).Copy
Sheet11.Select
Range("G" & Last_Row + 1).Select
ActiveSheet.Paste
'Column I to L
Sheet9.Select
Range("I2:I" & Last_Row).Copy
Sheet11.Select
Range("L" & Last_Row + 1).Select
ActiveSheet.Paste
End Sub
Question 1:
When I paste what I have copied to the other worksheet it directly pastes things in the "Last_Row" from the previous worksheet instead of looking for the new "Last_Row" of the Active Sheet. Is there a way around this?
Question 2
I repeat the same code several times but with different columns, because they are not together I copy column A to D, then C to F, etc.
It is working for me, but out of curiosity, is there a way to do it all at once?
(First Empty Row After) Last Non-Empty Row
Option Explicit
Sub Practice()
'Last Row Searcher
Const frSrc As Long = 2 ' Source First Row
Const strSrc As String = "A,C, E, I" ' Source Column Letters
Const strTgt As String = "D, F,G, L" ' Target Column Letters
Dim wsSrc As Worksheet ' Source Worksheet
Dim wsTgt As Worksheet ' Target Worksheet
Dim rngSrc As Range ' Source Column Range
Dim rngTgt As Range ' Target Column Range
Dim vntS As Variant ' Source Column Array
Dim vntT As Variant ' Target Column Array
Dim lrSrc As Long ' Source Last Non-Empty Row
Dim frTgt As Long ' Target First Row After Last Non-Empty Row
Dim i As Long ' Source and Target Array Elements Counter
Dim colSrc As String ' Source Column Letter
Dim colTgt As String ' Target Column Letter
' Beware, you are using CodeNames, which are not the names on the TAB.
Set wsSrc = Sheet9
Set wsTgt = Sheet11
' Populate Column Arrays (vntS, vntT).
vntS = Split(strSrc, ","): vntT = Split(strTgt, ",")
' Loop through elements of Source (or Target) Column Array.
For i = 0 To UBound(vntS)
' Calculate Column Letter (colSrc, colTgt)
colSrc = Trim(vntS(i)): colTgt = Trim(vntT(i))
' Calculate Source Last Non-Empty Row.
lrSrc = wsSrc.Range(colSrc & wsSrc.Rows.Count).End(xlUp).Row
' Calculate Target First Row After Last Non-Empty Row.
frTgt = wsTgt.Range(colTgt & wsTgt.Rows.Count).End(xlUp).Row + 1
' Calculate Source Column Range.
Set rngSrc = wsSrc.Range(colSrc & frSrc & ":" & colSrc & lrSrc)
' Calculate Target Column Range.
Set rngTgt = wsTgt.Range(colTgt & frTgt).Resize(rngSrc.Rows.Count)
' Write values of Source Column Range to Target Column Range.
rngTgt.Value = rngSrc.Value
Next
End Sub
EDIT:
Sub Practice2()
'Last Row Searcher
Const frSrc As Long = 2 ' Source First Row
Const strSrc As String = "A,C, E, I" ' Source Column Letters
Const strTgT As String = "D, F,G, L" ' Target Column Letters
Dim wsSrc As Worksheet ' Source Worksheet
Dim wsTgt As Worksheet ' Target Worksheet
Dim rngSrc As Range ' Source Column Range
Dim rngTgt As Range ' Target Column Range
Dim vntS As Variant ' Source Column Array
Dim vntT As Variant ' Target Column Array
Dim lrSrc As Long ' Source Last Non-Empty Row
Dim frTgt As Long ' Target First Row After Last Non-Empty Row
Dim i As Long ' Source and Target Array Elements Counter
Dim colSrc As String ' Source Column Letter
Dim colTgt As String ' Target Column Letter
' Beware, you are using CodeNames, which are not the names on the TAB.
Set wsSrc = Sheet9
Set wsTgt = Sheet11
' Populate Column Arrays (vntS, vntT).
vntS = Split(strSrc, ",")
vntT = Split(strTgT, ",")
' Calculate Target First Row After Last Non-Empty Row.
frTgt = wsTgt.Range(Trim(vntT(0)) & wsTgt.Rows.Count).End(xlUp).Row + 1
' Loop through elements of Source (or Target) Column Array.
For i = 0 To UBound(vntS)
' Calculate Column Letter (colSrc, colTgt)
colSrc = Trim(vntS(i)): colTgt = Trim(vntT(i))
' Calculate Source Last Non-Empty Row.
lrSrc = wsSrc.Range(colSrc & wsSrc.Rows.Count).End(xlUp).Row
' Calculate Source Column Range.
Set rngSrc = wsSrc.Range(colSrc & frSrc & ":" & colSrc & lrSrc)
' Calculate Target Column Range.
Set rngTgt = wsTgt.Range(colTgt & frTgt).Resize(rngSrc.Rows.Count)
' Write values of Source Column Range to Target Column Range.
rngTgt.Value = rngSrc.Value
Next
End Sub
You need to set define the "last row" more clearly. In your case, I believe what you want is to find the last row of the source data AND then paste it after the last row of your destination sheet. So try something like this:
Dim srcWS As Worksheet
Set srcWS = Sheet9
Dim dstWS As Worksheet
Set dstWS = Sheet11
Dim srcLastRow As Long
With srcWS
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Dim dstLastRow As Long
With dstWS
dstLastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
End With
srcWS.Range("A2:A" & srcLastRow).Copy
dstWS.Range("D" & dstLastRow).Paste
No Select or ActiveSheet is necessary (which you should avoid whenever you can).
Adding another answer here because my previous answer was incomplete (and it's been bothering me since yesterday!). Since this is a repetitive bit of code, I would separate the column-copy into it's own sub. Your logic becomes very simple in your main routine.
Option Explicit
Sub test()
CopyMyColumn Sheet1.Range("A1").EntireColumn, Sheet1.Range("D1").EntireColumn
CopyMyColumn Sheet1.Range("C1").EntireColumn, Sheet1.Range("F1").EntireColumn
CopyMyColumn Sheet1.Range("E1").EntireColumn, Sheet1.Range("G1").EntireColumn
CopyMyColumn Sheet1.Range("I1").EntireColumn, Sheet1.Range("L1").EntireColumn
End Sub
Private Sub CopyMyColumn(ByRef srcColumn As Range, ByRef dstColumn As Range)
'--- copies the source column from row 2 to the end of the data, to
' the destination column, appending to the end of the existing data
Dim srcLastRow As Long
With srcColumn
srcLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim dstLastRow As Long
With dstColumn
dstLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim src As Range
Dim dst As Range
Set src = srcColumn.Cells(2, 1).Resize(srcLastRow, 1)
Set dst = dstColumn.Cells(1, 1).Offset(dstLastRow, 0).Resize(srcLastRow, 1)
dst.Value = src.Value
End Sub
I have a list of words in column A of the 2nd sheet, and I need a script for excel that does the following:
Checks the first word of column A on 2nd sheet and then filters column B 1st sheet by cells that contain that word.
Deletes all the already filtered rows that don't contain that word also on column C.
And then it iterates with the next word from the column A 2nd sheet list until it went through all the words.
Example:
Column A 2nd sheet:
hav
Column B 1st sheet:
have
Column C 1st sheet:
must
In this case it would delete all the row because altough column B contains "hav", column C doesn't.
Your description is rather poor, but I gave it a shot. Try this code on "Sheet1". Replace "Sheet2" with the name of the second Sheet. This will look into each work on "Sheet2" and delete all rows on Sheet1 whose column B contains that word. Not sure what you mean by column C, but that condition should be easy to add.
Let me know.
Sub Test()
Dim LastRow As Long
Dim LastRowS2 As Long
Dim Word As String
LastRowS2 = ThisWorkbook.Sheets("Sheet2").Cells(1, 1).End(xlDown).Row
LastRow = Cells(1, 1).End(xlDown).Row
For i = 2 To LastRowS2
For j = 2 To LastRow
Word = Split(ThisWorkbook.Sheets("Sheet2").Cells(i, "A").Text, " ")(0)
If InStr(Cells(j, "B").Text, Word) > 0 Then
If InStr(Cells(j, "C").Text, Word) > 0 Then
'Do nothing
Else
Cells(j, "B").EntireRow.Delete
j = j - 1
End If
End If
Next j
Next i
End Sub
Delete Column By Criteria
Links
Workbook Download
The Code
Sub DeleteColumnCriteria()
' Worksheet 1
Const csheet1 As Variant = "Sheet1" ' Worksheet Name/Index
Const cFirstR1 As Long = 2 ' First Row
Const cCol1 As Variant = "B" ' Criteria Column 1
Const cCol2 As Variant = "C" ' Criteria COlumn 2
' Worksheet 2
Const cSheet2 As Variant = "Sheet2" ' Worksheet Name/Index
Const cFirstR2 As Long = 2 ' First Row
Const cCol As Variant = "A" ' Criteria Column
' Worksheet 1
Dim rngU As Range ' Union Range
Dim LastR1 As Long ' Last Row Number
Dim i As Long ' Row Counter
' Worksheet 2
Dim ws2 As Worksheet ' Worksheet 2
Dim LastR2 As Long ' Last Row Number
Dim j As Long ' Row Counter
Application.ScreenUpdating = False
' Calculate Last Row of Worksheet 2.
Set ws2 = ThisWorkbook.Worksheets(cSheet2)
LastR2 = ws2.Cells(ws2.Rows.Count, cCol).End(xlUp).Row
With ThisWorkbook.Worksheets(csheet1)
' Calculate Last Row of Worksheet 1.
LastR1 = .Cells(.Rows.Count, cCol1).End(xlUp).Row
' Accumulate ranges into Union Range.
For i = cFirstR2 To LastR2 ' Loop through rows in Worksheet 2.
For j = cFirstR1 To LastR1 ' Loop through rows in Worksheet 1.
' When value in cCol in Worksheet 2 is equal to cCol1 and
' not in cCol2 in Worksheet 1.
If ws2.Cells(i, cCol) <> "" Then
If ws2.Cells(i, cCol) = .Cells(j, cCol1) _
And ws2.Cells(i, cCol) <> .Cells(j, cCol2) Then
If Not rngU Is Nothing Then ' All other times.
Set rngU = Union(rngU, .Cells(j, 1))
Else ' First time only.
Set rngU = .Cells(j, 1)
End If
End If
End If
Next
Next
End With
' Delete rows in one go.
If Not rngU Is Nothing Then
rngU.EntireRow.Delete ' Hidden = True
End If
Application.ScreenUpdating = True
End Sub
I have an excel chart with a bunch of data
Every few rows is blank
When there is a blank row I would like to concatenate the cells in column A and last 4 characters of column B from the row below, as long as the cell in column A below does not equal "."
I have the following:
Sub Macro3()
'
' Macro3 Macro
'
'
For Each cell In Columns("A")
If ActiveCell.Value = "" Then ActiveCell.FormulaR1C1 = _
"=IF(R[1]C<>""."",CONCATENATE(R[1]C,RIGHT(R[1]C[1],4)),"""")"
Range("A2").Select
Next cell
End Sub
Why entire Col A?
If you are using the cell object to loop then why use ActiveCell?
My recommendation is to find the last row in Col A and then take that into account in identifying your actual range and then loop through that.
Is this what you are trying?
Sub Sample()
Dim aCell As Range
Dim lRow As Range
Dim ws As Worksheet
'~~> Change this to the relevant sheet name
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Last row in col A which has data
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Check each cell in the relevant range
For Each aCell In .Range("A1:A" & lRow)
If aCell.Value = "" Then _
aCell.FormulaR1C1 = "=IF(R[1]C<>""."",CONCATENATE(R[1]C,RIGHT(R[1]C[1],4)),"""")"
Next aCell
End With
End Sub