Sub foo()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("test")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1,
Criteria1:=Worksheets("test").Cells(1, 26).Value
ws.Range("f2:f" & LastRow).SpecialCells(xlCellTypeVisible).Copy Range("C6")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "C").End(xlUp).Row + 1
wsDestination.Range("C" & DestinationRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
End Sub
Good evening, Paste values part is giving me an object defined error and I don't know why
You want a test to ensure there are visible cells to copy from:
If Application.WorksheetFunction.Countif(ws.Range("A1:N" & LastRow),Worksheets("test").Cells(1, 26).Value) > 0
. A test that you have more than one cell for your filter
If LastRow > 1
and you also have already pasted with this line:
ws.Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible).Copy Range("C6")
You pasted to C6 and now have an empty clipboard so cannot paste again.
Perhaps you wanted:
ws.Range("F2:F" & LastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "C").End(xlUp).Row + 1
wsDestination.Range("C" & DestinationRow).PasteSpecial xlPasteValues
You have already pasted the copied cells into the inbd sheet C6.
Your code does not make much sense. You determine the last row of data before you filter, you copy and paste, then you paste again. I suggest you first filter, then determine the last row in both sheets, then do the copy and paste special right after one another without the wrong paste to C6 step.
Related
I'm dealing with an error and I don't really know what to do with it.
Private Sub commandbutton1_click()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("sheet1")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("sheet1").Cells(1, 5).Value
This line of code below is giving me an error.
Sheets("INBD").Range("D2", Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(2, 4).Copy _
Destination:=Sheets(1).Range("J1:K2")
It's supposed to copy the first visible cell in column D. (Credit: This part of the code was given to me by user "Marcucciboy2") I can't figure out how to integrate it with the rest of the code though.
Application.Run ("Macro8")
Application.Run ("Macro4")
Application.Run ("Macro5")
Application.Run ("Macro6")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("sheet1").Cells(1, 5).Value
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
End Sub
Sheets("INBD").Range("D2", Cells(Rows.Count, "D").End(xlUp)).SpecialCells(xlCellTypeVisible)
returns a block of cells one column wide - so it can't have a cells(2,4) as that defines something in the fourth column. You want cells(1,1) - the first cell within the visible cells.
Cells defines a cell with reference to a specified range unless you use Worksheets(X).cells in which case it's by reference to the whole spreadsheet: so Sheets("INBD").Cells(2,4) is cell D2, but Range("A100:D200").cells(2,4) is cell D200
To sum up, I try to copy some filtered data from a workbook A to a workbook B keeping the formatting of the workbook B.
Here is the relevant part of my code:
With originSheet
.AutoFilterMode = False
With .Range("A7:AA" & lastRowOriginSheet)
.AutoFilter Field:=2, Criteria1:=projectNumber
.SpecialCells(xlCellTypeVisible).Copy
End With
End With
destinationSheet.Range("B4").PasteSpecial xlPasteValues
The paste special is not working and this is the formatting of the workbook A that is used.
Solved:
The problem was that you can't use PasteSpecial in a discontinuous range.
So I went with the solution of Siddharth Rout to go through all the areas of the filtered range:
With originSheet
.AutoFilterMode = False
With .Range("A7:AA" & lastRowOriginSheet)
.AutoFilter Field:=2, Criteria1:=projectNumber
Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Loop through each area
For Each area In filteredRange.Areas
With destinationSheet
'~~> Find Next available row
lRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
area.Copy
destinationSheet.Range("B" & lRow).PasteSpecial xlPasteValues
End With
Next area
End With
End With
What #Jeeped has mentioned is very true that you cannot used Paste Special on a filtered range if they are Non Contiguous. However there is a way to achieve what you want :)
You have to loop through each area of the filtered range and then use Paste Special as shown below
Sub Sample()
Dim ws As Worksheet
Dim lastRowOriginSheet As Long
Dim filteredRange As Range, a As Range
Dim projectNumber As Long
'~~> I have set these for testing. Change as applicable
projectNumber = 1
Set ws = Sheet1
Set destinationSheet = Sheet2
lastRowOriginSheet = 16
With ws
.AutoFilterMode = False
With .Range("A7:AA" & lastRowOriginSheet)
.AutoFilter Field:=2, Criteria1:=projectNumber
Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Loop through each area
For Each a In filteredRange.Areas
With destinationSheet
'~~> Find Next available row
lRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
a.Copy
destinationSheet.Range("B" & lRow).PasteSpecial xlPasteValues
End With
Next a
End With
End With
End Sub
In Action
PasteSpecial does not work on a discontiguous range. If you have one hidden row in among visible rows then you have a discontiguous range. However, due to the nature of a discontiguous range, a straight copy and paste will paste formats and the values from formulas; i.e. it cannot determine how to shift the cell ranges in formulas so it just pastes values.
With originSheet
.AutoFilterMode = False
With .Range("A7:AA" & lastRowOriginSheet)
.AutoFilter Field:=2, Criteria1:=projectNumber
'you should probably check to ensure you have visible cells before trying to copy them
.SpecialCells(xlCellTypeVisible).Copy destination:=destinationSheet.Range("B4")
End With
End With
Try this. Instead of doing PasteSpecial, since you just need values, you can set the ranges equal to eachother.
Dim copyRng As Range
With originSheet
.AutoFilterMode = False
With .Range("A7:AA" & lastRowOriginSheet)
.AutoFilter Field:=2, Criteria1:=projectNumber
Set copyRng = .SpecialCells(xlCellTypeVisible)
End With
End With
' destinationSheet.Range("B4").Value = copyRng.Value
With destinationSheet
.Range(.Cells(4, 2), .Cells(4 + copyRng.Rows.Count - 1, 2 + copyRng.Columns.Count - 1)).Value = copyRng.Value
End With
(this is assuming your worksheet and lastRow and projectNumber are all declared properly and working).
Edited because if you just do Range("B4").Value = Range("A1:Z100").Value, it's only going to put the first value in your copied range in the cell. You need to expand the destination range to be the size of the copy range.
I am running into issues with the Paste Special part of the following code
Sub Copy_Filter1()
Sheets("MASTER PLACEMENT").Select
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Sheets("MASTER PLACEMENT").Range("A1").CurrentRegion.AutoFilter
Selection.AutoFilter Field:=52, Criteria1:=">=104"
Columns("AG:AS").EntireColumn.Hidden = True
Rows("1:1").EntireRow.Hidden = True
If (Range("A" & Rows.Count).End(xlUp).Row <= LastRow) Then
Range("A2").CurrentRegion.Copy
Sheets("Sheet1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
End If
End Sub
PasteSpecial is a method of the Range object, not the Worksheet object (which is where you are currently using it).
For example, your call should look like:
' Paste the current clipboard contents to cell B2 on Sheet1.
Sheets("Sheet1").Range("B2").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
use something like below
Sub Copy_Filter1()
Sheets("Sheet1").Range("A1:A1000").Select
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet1").Range("A1").CurrentRegion.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:=">=104"
If (Range("A" & Rows.Count).End(xlUp).Row <= LastRow) Then
Range("A2").CurrentRegion.Copy
Sheets("Sheet1").Range("C3").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
End Sub
I have a copy / paste loop for line items in an Excel file that exports data from these line items into an Excel-based form and saves each form by the value in Row B. My issue is that these line items are divided into 3 different tables on the same sheet, each with a different number of line items to be copied. Furthermore, each table is separated by 2 blank rows.
What I need the macro to do for me:
Start at line 17 and copy all line items in the first table until it hits a blank row - this varies from 1 to 600 rows.
Skip to SecondTable and perform the same functions.
Repeat for ThirdTable
Ignore some of the declarations as I deleted a large chunk of code for readability. I figured I would need 3 separate copy/paste loops to accomplish this (I've only included 2 here) and I tried using .Find to reference the start of the second/third tables. The macro runs as normal through the first table, but doesn't stop when it hits a blank row and fails when it tries to save a file based on the value of an empty cell. I believe the issue lies with the EndOne = .Range("B" & .Rows.Count).End(xlUp).Row argument right under With wsSource. Instead of counting only the non-blank rows of the first table, it counts the number of rows through the end of the third table.
Sub CopyToForm()
Dim wbSource As Workbook, wbForm As Workbook
Dim wsSource As Worksheet, wsForm As Worksheet
Dim formpath As String, foldertosavepath As String
Dim EndOne As Long, EndTwo As Long, EndThree As Long, i As Integer
Dim strProcessingFormPath As String
'Dim strCancel As String
'Dim strFilt As String
'Dim intFilterIndex As Integer
'Dim strDialogueFileTitle As String
Dim SecondTable As String
Dim ThirdTable As String
Set wbSource = ThisWorkbook '~~> Write your code in Indication Tool.xls
Set wsSource = wbSource.Sheets("Indication Tool") '~~> Put the source sheet name
With wsSource
'~~> Counts how many rows are in the Indication Tool
EndOne = .Range("B" & .Rows.Count).End(xlUp).Row
If EndOne < 17 Then MsgBox "No data for transfer": Exit Sub
For i = 17 To EndOne
Set wbForm = Workbooks.Open(formpath) '~~> open the form
Set wsForm = wbForm.Sheets("Processing Form") '~~> Declare which worksheet to activate
'~~> Proceed with the copying / pasting of values
.Range("B" & i).Copy wsForm.Range("F7:K7")
.Range("C" & i).Copy: wsForm.Range("D8").PasteSpecial xlPasteValues
.Range("C" & i).Copy: wsForm.Range("D30").PasteSpecial xlPasteValues
.Range("D" & i).Copy: wsForm.Range("H29").PasteSpecial xlPasteValues
.Range("E" & i).Copy: wsForm.Range("E29").PasteSpecial xlPasteValues
.Range("F" & i).Copy: wsForm.Range("D33").PasteSpecial xlPasteValues
.Range("G" & i).Copy: wsForm.Range("K30").PasteSpecial xlPasteValues
.Range("H" & i).Copy: wsForm.Range("P33").PasteSpecial xlPasteValues
.Range("L" & i).Copy: wsForm.Range("H32").PasteSpecial xlPasteValues
.Range("R" & i).Copy: wsForm.Range("D87").PasteSpecial xlPasteValues
'.Range("C5:M5").Copy: wsForm.Range("E102").PasteSpecial xlPasteValues
'~~> Save the form using the value in cell i,B
wbForm.SaveAs .Range("B" & i).Value & ".xls"
wbForm.Close
Set wbForm = Nothing
Set wsForm = Nothing
Next
End With
With wsSource
SecondTable = .Range("B:B").Find("SecondTable").Row
EndTwo = .Range("B" & .Rows.Count).End(xlUp).Row
For i = Second Table + 1 To EndTwo
Set wbForm = Workbooks.Open(formpath) '~~> open the form
Set wsForm = wbForm.Sheets("Processing Form") '~~> Declare which worksheet to activate
'~~> Proceed with the copying / pasting of values
.Range("B" & i).Copy wsForm.Range("F7:K7")
.Range("C" & i).Copy: wsForm.Range("D8").PasteSpecial xlPasteValues
.Range("C" & i).Copy: wsForm.Range("D30").PasteSpecial xlPasteValues
.Range("D" & i).Copy: wsForm.Range("H29").PasteSpecial xlPasteValues
.Range("E" & i).Copy: wsForm.Range("E29").PasteSpecial xlPasteValues
.Range("F" & i).Copy: wsForm.Range("D33").PasteSpecial xlPasteValues
.Range("G" & i).Copy: wsForm.Range("K30").PasteSpecial xlPasteValues
.Range("H" & i).Copy: wsForm.Range("P33").PasteSpecial xlPasteValues
.Range("L" & i).Copy: wsForm.Range("H32").PasteSpecial xlPasteValues
.Range("R" & i).Copy: wsForm.Range("D87").PasteSpecial xlPasteValues
.Range("C5:M5").Copy: wsForm.Range("E102").PasteSpecial xlPasteValues
'~~> Save the form using the cells i,B
wbForm.SaveAs .Range("B" & i).Value & ".xls"
wbForm.Close
Set wbForm = Nothing
Set wsForm = Nothing
Next
End With
End Sub
Am I on the right track with the .Find and a separate copy/paste loop for each table? I realize this is a complex problem and I appreciate any time you take to spend helping me out.
Am I on the right track with the .Find and a separate copy/paste loop for each table?
Not exactly. The code inside those loops is largely the same, so it is a good candidate for subroutine. This will make your code more human-readable, and also makes it easier to maintain since there will only be one place to make revisions, instead of multiple (imagine if you needed to do 10 different iterations, or 1,000 -- you wouldn't possibly write 1,000 different loops to do the same thing!!)
Consider this instead (I observe a few obvious errors which I will correct, but this is not tested). What I have done is to take your several loops, and consolidate them in to a single subroutine. Then we send some information like where the table starts and where it ends, to that subroutine:
Sub CopyStuff(ws as Worksheet, tblStart as Long, tblEnd as Long)
We will send it: wsSource, and the other variables will be used/re-used to determine the start/end of each table. I removed the redundant variables (unless they need to be re-used elsewhere, having two variables EndOne and EndTwo is unnecessary: we can make use of more generic variables like tblStart and tblEnd which we can reassign for subsequent tables.
In this way it is a lot more apparent that we are processing multiple tables in an identical manner. We also have only a single For i = ... loop to manage, should the code require changes in the future. So it is easier to comprehend, and easier to maintain.
Sub CopyToForm()
Dim wbSource As Workbook 'No longer needed in this context: wbForm As Workbook
Dim wsSource As Worksheet 'No longer needed in this context: wsForm As Worksheet
Dim formpath As String, foldertosavepath As String
Dim tblEnd As Long, tblStart As Long, i As Integer
Dim strProcessingFormPath As String
Dim tblStart as Integer: tblStart = 16
Set wbSource = ThisWorkbook '~~> Write your code in Indication Tool.xls
Set wsSource = wbSource.Sheets("Indication Tool") '~~> Put the source sheet name
With wsSource
'~~> Counts how many rows are in the Indication Tool
tblEnd = .Range("B" & .Rows.Count).End(xlUp).Row
If tblEnd < 17 Then GoTo EarlyExit '## I like to use only one exit point from my subroutines/functions
CopyStuff wsSource, tblStart, tblEnd
tblStart = .Range("B:B").Find("SecondTable").Row + 1
tblEnd = .Range("B" & .Rows.Count).End(xlUp).Row
CopyStuff wsSource, tblStart, tblEnd
'And presumably...
tblStart = .Range("B:B").Find("ThirdTable").Row + 1
tblEnd = .Range("B" & .Rows.Count).End(xlUp).Row
CopyStuff wsSource, tblStart, tblEnd
End With
Exit Sub
EarlyExit:
MsgBox "No data for transfer"
End Sub
Private Sub CopyStuff(ws As Worksheet, tblStart as Long, tblEnd as Long)
Dim wbForm as Workbook, wsForm as Worksheet, i As Long
With ws
For i = tblStart to tblEnd
Set wbForm = Workbooks.Open(formpath) '~~> open the form
Set wsForm = wbForm.Sheets("Processing Form") '~~> Declare which worksheet to activate
'~~> Proceed with the copying / pasting of values
.Range("B" & i).Copy wsForm.Range("F7:K7")
.Range("C" & i).Copy: wsForm.Range("D8").PasteSpecial xlPasteValues
.Range("C" & i).Copy: wsForm.Range("D30").PasteSpecial xlPasteValues
.Range("D" & i).Copy: wsForm.Range("H29").PasteSpecial xlPasteValues
.Range("E" & i).Copy: wsForm.Range("E29").PasteSpecial xlPasteValues
.Range("F" & i).Copy: wsForm.Range("D33").PasteSpecial xlPasteValues
.Range("G" & i).Copy: wsForm.Range("K30").PasteSpecial xlPasteValues
.Range("H" & i).Copy: wsForm.Range("P33").PasteSpecial xlPasteValues
.Range("L" & i).Copy: wsForm.Range("H32").PasteSpecial xlPasteValues
.Range("R" & i).Copy: wsForm.Range("D87").PasteSpecial xlPasteValues
'.Range("C5:M5").Copy: wsForm.Range("E102").PasteSpecial xlPasteValues
'~~> Save the form using the value in cell i,B
wbForm.SaveAs .Range("B" & i).Value & ".xls"
wbForm.Close
Set wbForm = Nothing
Set wsForm = Nothing
Next
End With
End Sub
I have two sheets containing the employee records.
Sheet1 contains the Event Date, CardNo, Employee Name, Dept Id, Employee No, Entry and Exit Time, Total Working Hours, Status, ConcatinatedColumn and Remarks (copied through vlookup from sheet2)
Sheet2 contains ConcatinatedColumn, Event Date, Employee No, Name, Remarks.
If the data in the remarks column of sheet2 is "Sick Off" then that row should be inserted to sheet1 without effecting the previous records.
I've already written the code for it but it does not work.
Would be really grateful if anyone can help me out !
THANKS IN ADVANCE !
MY CODE :
Sub SickOff()
Dim objWorksheet As Sheet2
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Sheet1
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Sheet2")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("G2:G" & objWorksheet.Cells(Rows.Count, "G").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells
objWorksheet.Select
If rngCell.Value = "Sick Off" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Worksheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
Let's say you have data in Sheet2 as shown below
Let's say the end of data in Sheet1 looks like this
Logic:
We are using autofilter to get the relevant range in Sheet2 which match Sick Off in Col G. Once we get that, we copy the data to the last row in Sheet1. After the data is copied, we simply shuffle data across to match the column headers. As you mentioned that the headers won't change so we can take the liberty of hardcoding the column names for shuffling this data.
Code:
Paste this code in a module
Option Explicit
Sub Sample()
Dim wsI As Worksheet, wsO As Worksheet
Dim lRow As Long, wsOlRow As Long, OutputRow As Long
Dim copyfrom As Range
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> This is the row where the data will be written
OutputRow = wsI.Range("A" & wsI.Rows.Count).End(xlUp).Row + 1
With wsO
wsOlRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter G on "Sick Off"
With .Range("G1:G" & wsOlRow)
.AutoFilter Field:=1, Criteria1:="=Sick Off"
Set copyfrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
If Not copyfrom Is Nothing Then
copyfrom.Copy wsI.Rows(OutputRow)
'~~> Shuffle data
With wsI
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A" & OutputRow & ":A" & lRow).Delete Shift:=xlToLeft
.Range("F" & OutputRow & ":F" & lRow).Copy .Range("K" & OutputRow)
.Range("F" & OutputRow & ":F" & lRow).ClearContents
.Range("B" & OutputRow & ":B" & lRow).Copy .Range("E" & OutputRow)
.Range("B" & OutputRow & ":B" & lRow).ClearContents
End With
End If
End Sub
Output: