Below code helps me out, if on sheet1, specific date on column L is less than or equal to today's date, from sheet1 copy specific rows to sheet2 starting with A3 and do it for the whole list.
I have two follow up questions;
I want copied cells on sheet2 to be inserted on a newly created row ( need to incorporate End(xlUp) ) . Couldn't figure out yet
For some reason code doesn't work if my first sheet have filters on... I have to remove filters for the code. Not sure why it is not working regardless of filters on or off.
Sub CopyRange()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
Range("L1:L" & LastRow).AutoFilter Field:=1, Criteria1:="<=" & Date
Intersect(Rows("2:" & LastRow),
Range("A:A,F:H,K:L,R:R,U:U").SpecialCells(xlCellTypeVisible)).Copy
Sheets("Sheet2").Cells(3, 1)
Range("L1").AutoFilter
Application.ScreenUpdating = True
End Sub
Just use Range("L:L"). Also, I would suggest you use With ActiveSheet or better yet With Worksheet("sheetname")
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With Worksheets("Sheet1")
Range("L:L").AutoFilter Field:=1, Criteria1:="<=" & Date
Intersect(Rows("2:" & LastRow), _
Range("A:A,F:H,K:L,R:R,U:U").SpecialCells(xlCellTypeVisible)).Copy _
Sheets("Sheet2").Cells(3, 1)
Range("L1").AutoFilter
End With
Application.ScreenUpdating = True
Related
I am looking for some help modifying existing code in a worksheet that I had created a while back to copy and paste a range from a row rather than the entire row itself.
The original code, which has worked perfect in the original intended function, it would search column A in the Data worksheet for a specified match. it would then copy that row into a specified worksheet and paste each match as a new row.
What I have been trying to modify the code to do now is perform that same search of column A for either " New, Existing Being Removed, Existing To Remain". When finding one of the 3 options it would then copy the data from columns b:g of that matching row and paste it into the rent worksheet starting at a specified cell. For instance rows marked as Existing to remain would need to star being pasted at cell B3, Existing being removed cell m3, and New cell x3. In total there would not be more than 20 rows from the data sheet that would need to be copied and pasted appropriately.
The code below is the current working code that will search, copy, and paste the entire matching row. Not being extremely proficient with VBA code I didn't want to post the muddled mess that I had made of the original code.
Edit With Photos*
#Toddleson I made the changes you suggested but ended up getting an error with the copyfrom.copy line. It is probably much easier to see what I am trying to accomplish visually. In the Data sheet image link below you will see that row A is where the search occurs. For each match it will copy the values from columns B:G of that row and then paste that into the rent sheet.
If you take a look at the rent image you will see that it is broken into the 3 cooresponding sections. From the match that was found in the cooresponing deisgnation from column A in the data sheet it will then paste the information from columns B:G in the Data to the B:G columns in the Rent sheet.
Data Sheet
Rent
Private Sub CommandButton4_Click()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel
Dim strSearch As String
Set wb1 = ThisWorkbook
Set ws1 = wb1.Worksheets("Data")
strSearch = "New"
With ws1
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Resize(lRow - 1, 7)
End With
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Rent")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=Range("p3"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy ws2.Cells(3, 16).Resize(copyFrom.Rows.Count, copyFrom.Columns.Count)
End With
strSearch = "Existing Being Removed"
With ws1
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Rent")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=Range("p19"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy ws2.Cells(3, 16).Resize(copyFrom.Rows.Count, copyFrom.Columns.Count)
End With
strSearch = "Existing To Remain"
With ws1
.AutoFilterMode = False
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("A1:A" & lRow)
.AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
.AutoFilterMode = False
End With
Set ws2 = wb1.Worksheets("Existing To Remain")
With ws2
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("p35"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
copyFrom.Copy ws2.Cells(3, 16).Resize(copyFrom.Rows.Count, copyFrom.Columns.Count)
End With
End Sub
I have two tables placed in many sheets. I go through the sheets copying the data from one of the two tables. The range can vary, so it is not something I can statically code the range.
Each table ends in "Total" so that was the string I was attempting to find in the column and setting the last row equal to "Total's" row.
How do I copy the range of my second table (green background). These tables will not be the same range for each sheet.
I have set it up so the 'addSetB' which copies the first table (blue background) by copying the range and ending at "Total". So for 'addSetC' I tried setting it up so it will begin copying after the first total and stop at the second table, grabbing the range of the second table.
Is there a better way to accomplish this? Or how should I go about fixing my current code?
I get
runtime error 91: "Object variable or With block variable not set".
Highlighting the 'startRow' line.
Updated Sub addSetC() code. Now throwing:
Runtime-error: 1004 "Application-defined or object-defined error"
for ActiveSheet.Range("L" & startRow & ":Q" & lastRow).Copy after implementing BigBen's suggestion.
Table layout
' Copy range of the green background (not working / throwing errors)
Sub addSetC()
Dim lastL As Long
lastL = ActiveSheet.Range("L" & rows.Count).End(xlUp).row
Dim FoundRow As Range
Dim startRow As Integer
Dim lastRow As Integer
Dim rng As Range
With ActiveSheet.Range("L2:L" & lastL)
'Set startRow to first "Total"
Set rng = .Find(What:="Total", LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If Not rng Is Nothing Then startRow = rng.row
'Set lastRow to second "Total"
Set rng = .Find(What:="Total", _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then lastRow = rng.row
ActiveSheet.Range("L" & startRow & ":Q" & lastRow).Copy
End With
Sheets("DATA").Activate
Cells(Range("A" & rows.Count).End(xlUp).row + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
The above code is not copying the second table.
Here's what I used to copy the first table (blue background) which is working. How do implement this in my other subroutine to copy the other table?
' Copy range of blue background (functioning properly)
Sub addSetB()
Dim lastRow As Integer
lastRow = Cells.Find(What:="Total", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
Range("L3:Q" & lastRow).Copy
Sheets("DATA").Activate
Cells(Range("A" & rows.Count).End(xlUp).row + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
I am trying to accelerate my Excel VB Macro.
I have tried the 5 alternatives below.
But I wonder if I could shorten the execution further.
I found 2 alternatives in User Blogs which I could not get to work.
One alternative is also found in a User Blog but do not understand.
Sub AccelerateMacro()
'
' v1 052817 by eb+mb
' Macro to copy as fast as possible sheet from one workbook into another workbooks
' Declarations for variables are not shown to make code example more legible
' Macro is stored in and run from "DestinationWorkBook.xlsm"
StartTime = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Alternative = "First"
If Alternative = "First" Then
Workbooks.Open Filename:="SourceWorkBook.xls"
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Windows("SourceWorkBook.xls").Activate
ActiveWorkbook.Close
End If
If Alternative = "Second" Then
Workbooks.Open Filename:="SourceWorkBook.xls", ReadOnly:=True
Cells.Select
Selection.Copy
Windows("DestinationWorkBook.xlsm").Activate
Sheets("DestinationSheet").Select
Range("A1").Select
ActiveSheet.Paste
Workbooks("SourceWorkBook.xls").Close SaveChanges:=False
End If
If Alternative = "Third" Then
' I could not get this alternative to work
Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet").Copy
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1").PasteSpecial
End If
If Alternative = "Fourth" Then
' I could not get this alternative to work
Workbooks.Open("DestinationWorkBook.xlsm").Worksheets("DestinationSheet").Range("A1") = Workbooks.Open("SourceWorkBook.xls").Worksheets("SourceSheet")
End If
If Alternative = "Fifth" Then
' I don't understand the code in this alternative
Dim wbIn As Workbook
Dim wbOut As Workbook
Dim rSource As Range
Dim rDest As Range
Set wbOut = Application.Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Application.Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet").UsedRange
wbOut.Sheets("DestinationSheet").Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Instead of using UsedRange, find the actual Last Row and Last Column and use that range. UsedRange may not be the range that you think it is :). You may want to see THIS for an explanation.
See this example (UNTESTED)
Sub Sample()
Dim wbIn As Workbook, wbOut As Workbook
Dim rSource As Range
Dim lRow As Long, LCol As Long
Dim LastCol As String
Set wbOut = Workbooks.Open("DestinationWorkBook.xlsm")
Set wbIn = Workbooks.Open("SourceWorkBook.xls")
With wbIn.Sheets("SourceSheet")
'~~> Find Last Row
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find Last Column
LCol = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Column Number to Column Name
LastCol = Split(Cells(, LCol).Address, "$")(1)
'~~> This is the range you want
Set rSource = .Range("A1:" & LastCol & lRow)
'~~> Get the values across
wbOut.Sheets("DestinationSheet").Range("A1:" & LastCol & lRow).Value = _
rSource.Value
End With
End Sub
I have a bit of code that finds blanks in a given column and replaces them with "BLANK", this has worked fine in the past and works for all of the sheets I am looking at bar one.
In the 'meter' sheet the whole column is blank, yet the find and replace fills all bar 6 of the blanks with no apparent pattern as below. I expect this could be another of my Monday morning 'user malfunction' errors but would appreciate any insight.
I am aware this would be better in a loop, which I will write once I've fixed the problem of it missing some blanks.
Cheers
Public Function FILL_blanks() '''' this searches for blanks
'in the columns in the raw data we are interested in and replaces
'them with BLANK there is a value assigned to BLANK in the flag matrix.
Dim LastRow_g As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim LastRow_j As Long ''''
Dim LastRow_bp As Long ''''
Dim WS_Count As Integer
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
If ActiveWorkbook.Worksheets(i).Name = "hydrant" Then
Worksheets(i).Select
Range("g4").Select ' this will change j/g/bp only
LastRow_g = Range("g" & Rows.Count).End(xlUp).Row 'define the last row as all of the rows in DMA flag column
Range("r4:r" & LastRow_g).Select
'find and replace below
Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ElseIf ActiveWorkbook.Worksheets(i).Name = "meter" Then
Worksheets(i).Select
Range("j4").Select
LastRow_j = Range("j" & Rows.Count).End(xlUp).Row 'define the last row
Range("y4:y" & LastRow_j).Select
'find and replace below
Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
I would use Sub here rather than Function because there doesn't seem to be a return. This code replaces blank cells in the columns specified above:
Option Explicit
Sub FillBlanks2() '''' this searches for blanks
Dim LastRow As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim Sheet As Worksheet
Dim TargetRange As Range
'loop through worksheets in this workbook
For Each Sheet In ThisWorkbook.Worksheets
If Sheet.Name = "hydrant" Then '<~ concerned with col G on hydrant sheet
With Sheet
LastRow = .Range("G" & .Rows.Count).End(xlUp).Row
Set TargetRange = .Range(.Cells(4, 7), .Cells(LastRow, 7))
End With
'apply replacement to the target range
TargetRange.Replace What:="", Replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
ElseIf Sheet.Name = "meter" Then '<~ concerned with col J on hydrant sheet
With Sheet
LastRow = .Range("J" & .Rows.Count).End(xlUp).Row
Set TargetRange = .Range(.Cells(4, 10), .Cells(LastRow, 10))
End With
'apply replacement to the target range
TargetRange.Replace What:="", Replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
End If
Next Sheet
End Sub
I adapted the code from Dan Wagner to account for cells that appear blank but actually have spaces in them. if the cells are only likely to contain a blank or one space then it is possible to use "" and " ".
However, I am sure there is a more elegant solution that accounts for all blank spaces. SpecialCells(xlCellTypeBlanks) is a possibility but it appears to be limited to a certain number of rows.
Sub FILL_blanks() '''' this searches for blanks
Dim LastRow As Long '''' HYDRANT, NODE ---->CHANGES LENGTH FOR EACH ASSET
Dim Sheet As Worksheet
Dim TargetRange As Range
Sheets("Sheet1").Select
LastRow = Range("a" & Rows.Count).End(xlUp).Row
Set TargetRange = Range("b4:b" & LastRow)
'apply replacement to the target range
'"" accounts for true blank cells (no spaces)
' "*" is a wildcard and accounts for one or more spaces
TargetRange.Replace What:="", replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
TargetRange.Replace What:=" ", replacement:="BLANK", LookAt:=xlWhole, SearchOrder:=xlByRows
End Sub
Thanks again for your assistance
I've got this table full of data. And column K in each row contains a number. So basically what I'm trying to do is move that entire row, if the data in that column is greater than 9, over to sheet2.
How can this be achieved? I've already created actual tables in the sheets, called Table1 and Table2.
This is what I've managed to put together so far. I've looked at autofilter, but I can't understand squat of what's happening in there. So this I get!
Sub MoveData()
Dim i As Range
Dim num As Integer
num = 1
For Each i In Range("K10:K1000")
If i.Value > 9 Then
i.Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet2").Range("A65000").End(xlUp).Offset(num, 0).PasteSpecial
ActiveCell.Rows.Delete
num = num + 1
End If
Next i
End Sub
This kinda works so far. But I can't manage to paste the row to the next blank row in sheet2. I tried doing that num = num + 1 thing, but I guess that's way off?
Is this what you are trying? (TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim rRange As Range
Dim lastRowWsO As Long
Set wsI = Sheets("sheet1")
'~~> Assuming that the Header is in K10
Set rRange = wsI.Range("K10:K1000")
Set wsO = Sheets("sheet2")
'~~> Get next empty cell in Sheet2
lastRowWsO = wsO.Range("A" & Rows.Count).End(xlUp).Row + 1
With wsI
'~~> Remove Auto Filter if any
.AutoFilterMode = False
With rRange
'~~> Set the Filter
.AutoFilter Field:=1, Criteria1:=">=9"
'~~> Temporarirly hide the unwanted rows
wsI.Rows("1:9").EntireRow.Hidden = True
wsI.Rows("1001:" & Rows.Count).EntireRow.Hidden = True
'~~> Copy the Filtered rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
wsO.Rows(lastRowWsO)
'~~> Delete The filtered rows
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'~~> Unhide the rows
.Rows("1:9").EntireRow.Hidden = False
.Rows("1001:" & Rows.Count).EntireRow.Hidden = False
'~~> Remove Auto Filter
.AutoFilterMode = False
End With
End Sub
NOTE: I have not included any error handling. I would recommend you to include one in the final code
FOLLOWUP
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim rRange As Range
Dim lastRowWsI As Long, lastRowWsO As Long
Set wsI = Sheets("Risikoanalyse")
'~~> Assuming that the Header is in K10
Set rRange = wsI.Range("K9:K1000")
lastRowWsI = wsI.Cells.Find(What:="*", _
After:=wsI.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Set wsO = Sheets("SJA utarbeides")
'~~> Get next empty cell in Sheet2
lastRowWsO = wsO.Cells.Find(What:="*", _
After:=wsO.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row + 1
With wsI
With .ListObjects("TableRisikoAnalyse")
'~~> Set the Filter
.Range.AutoFilter Field:=11, Criteria1:=">=9"
'~~> Temporarirly hide the unwanted rows
wsI.Rows("1:8").EntireRow.Hidden = True
wsI.Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = True
'~~> Copy the Filtered rows
wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).EntireRow.Copy _
wsO.Rows(lastRowWsO)
'~~> Clear The filtered rows
wsI.Range(Replace(wsI.Range("K9").Offset(1, 0).SpecialCells(xlCellTypeVisible).Address, "$9:$9,", "")).Clear
.Range.AutoFilter Field:=11
'~~> Sort the table so that blank cells are pushed down
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("TableRisikoAnalyse[[ ]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortTextAsNumbers
With .Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'~~> Unhide the rows
.Rows("1:8").EntireRow.Hidden = False
.Rows(lastRowWsI & ":" & Rows.Count).EntireRow.Hidden = False
'~~> Remove Auto Filter
.AutoFilterMode = False
End With
End Sub