I have a sub which looks for values in the SolutionID column that match an array of values in one table, and then copies that over to the other.
However, I'm hitting an error with the .PasteSpecial method -
Object doesn't support this property or method
Does anybody know what I am doing wrong? Thanks.
Private Sub CopySolutions(ByRef SourceTable As ListObject, ByRef DestinationTable As ListObject, ByRef values() As String)
On Error Resume Next
Dim i, j As Integer ' Dummy for looping
'** Loop through all of the ID's to copy... *'
For i = LBound(values) To UBound(values)
With SourceTable.DataBodyRange
For j = 1 To .Rows.Count
If .Cells(j, 1).Value = values(i) Then
.Rows(j).Copy ' Copy the row in the SourceTable
Dim LastRow As Integer
LastRow = DestinationTable.Rows.Count ' Work out the number of rows in the DestinationTable
'** Check to see if the last row in the destination table is already empty '*
If DestinationTable.DataBodyRange.Cells(LastRow, 1).Value <> "" Or LastRow = 0 Then
DestinationTable.ListRows.Add AlwaysInsert:=True ' Insert a new row in to the DestinationTable
LastRow = LastRow + 1 ' Increment LastRow to take in to account the newly added row
End If
DestinationTable.DataBodyRange.Cells(LastRow, 1).Select ' Select the last row, column 1 in the Destination Table
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False ' Paste the copied row
Exit For ' Exit the For, there is no need to keep checking for matches
End If
Next
End With
Next
If Err.Number <> 0 Then
Call ErrorOutput("An error occured while copying your selected solutions.")
End If
On Error GoTo 0
WS.Range("Solution").Select ' Reselect the Solution cell range
End Sub
Best to avoid copy/paste alltogether:
Dim rngSrc as Range
'...
Set rngSrc = .Rows(j)
'...
DestinationTable.DataBodyRange.Cells(LastRow, 1). _
Resize(1, rngSrc.Columns.Count).Value = rngSrc.Value
Try this:
SourceTable.DataBodyRange.Rows(j).Copy DestinationTable.DataBodyRange.Range("A" & CStr(lastRow))
after you find last row of course. That way you don't have to use .Select
Related
I would like the cells I have selected in the spreadsheet to receive the +1 increment. The code below works fine when I have a range, but when I have only one cells selected the code adds +1 to every cell in the spreadsheet.
Sub Macro_MAIS_1()
'
' Macro_MAIS_1 Macro
'
'
Dim AlocationWorksheet As Worksheet
Dim ActSheet As Worksheet
Dim SelRange As Range
Dim iCells As Integer
On Error GoTo Fim
Set AlocationWorksheet = Worksheets("ALOCAÇÃO")
AlocationWorksheet.Unprotect
Set ActSheet = ActiveSheet
Set SelRange = Selection.SpecialCells(xlCellTypeVisible)
iCells = SelRange.Cells.Count
Range("O7").Select
Selection.Copy
SelRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
Exit Sub
Fim:
MsgBox Selection.Address
Range("O7").Select
Selection.Copy
SelRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
:=False, Transpose:=False
End Sub
I would avoid using a selection, but this should work. If you have text you'll run into trouble and need to write out some checks. You also should not be counting all cells, as you might have an overflow of values. Check rows and columns, but not both.
Sub addPlusOne()
Dim aRange As Range, i As Long, j As Long
Set aRange = Selection
If aRange.Rows.Count > 1 Or aRange.Columns.Count > 1 Then
Dim zRng()
zRng = aRange.Value
For i = LBound(zRng) To UBound(zRng)
For j = LBound(zRng, 2) To UBound(zRng, 2)
zRng(i, j) = zRng(i, j) + 1
Next j
Next i
aRange.Value = zRng
Else
aRange.Value = aRange.Value + 1
End If
End Sub
EDIT: OP commented that they want to use visible selection. While this isn't best practice, this will work.
Sub plusOneOnSelection()
Dim aCell As Range
For Each aCell In Selection.SpecialCells(xlCellTypeVisible).Cells
If IsNumeric(aCell) Then aCell.Value = aCell.Value + 1
Next aCell
End Sub
I have two Workbooks that I need to copy/paste data from one workbook into the next available row in another workbook. The code I have below is almost working. You see, there is a total row at the bottom of the destination workbook. So, I'm trying to figure out how to insert a row at the next available row from the top, but instead, my code inserts the data below the totals row.
Here's how it looks in Excel. I'm trying to insert what would be Row C, but instead it inserts below the "Totals" row:
Row A 1 2 3 4
Row B 2 3 4 5
<-----Trying to Insert Here---------->
Totals 3 5 7 9
Here's my code"
:
Sub sbCopyToDestination()
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Worksheets("Sheet1").Range("f34:l34")
Dim NextFreeCell As Range
Set NextFreeCell = Workbooks("Destination.xlsm").Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Offset(RowOffset:=1)
SourceRange.Copy
NextFreeCell.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ThisWorkbook.Save
End Sub
Try the next code, please. It also updates the total, to include the pasted values.
Dim SourceRange As Range, destSh As Worksheet, NextFreeCell As Range
Set SourceRange = Range("f34:l34") ' ThisWorkbook.Worksheets("Sheet1").Range("f34:l34")
Set destSh = Workbooks("Book1").Worksheets("Sheet1") ' Workbooks("Destination.xlsm").Worksheets("Sheet1")
Set NextFreeCell = destSh.cells(Rows.count, "B").End(xlUp)
Application.CutCopyMode = 0
NextFreeCell.EntireRow.Insert xlDown
NextFreeCell.Offset(-1).Resize(, 2).Value = SourceRange.Value
'if you do not need to update the sum formula with the new inserted row, coamment the next row
NextFreeCell.Formula = UpdateFormula(NextFreeCell)
NextFreeCell.Offset(, 1).Formula = UpdateFormula(NextFreeCell.Offset(, 1))
ThisWorkbook.Save
End Sub
Function UpdateFormula(rng As Range) As String
Dim x As String
x = rng.Formula
UpdateFormula = Replace(x, Split(x, ":")(1), _
Replace(Split(x, ":")(1), rng.Row - 2, rng.Row - 1))
End Function
Try this
Sub sbCopyToDestination()
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Worksheets("Sheet1").Range("f34:l34")
Dim NextFreeCell As Range
Set NextFreeCell = Workbooks("Destination.xlsm").Worksheets("Sheet1").Cells(Rows.count, "B").End(xlUp) ' No offset
With SourceRange
NextFreeCell.Resize(.Rows.count, 1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
NextFreeCell.Resize(.Rows.count, .Columns.count).Value = .Value
End With
ThisWorkbook.Save
End Sub
in the range A1 to A70, if a cell is empty/blank then delete that entire row and move the other rows underneath up
Thank you
Use following codes.
Sub RemoveDuplicate()
On Error Resume Next
Range("A1:A70").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Edit:
Sub RemoveBlankRowsInARange()
Dim rng As Range, rws As Long, i As Long
Dim LastRow As Long
' LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Set rng = ActiveSheet.Range("A2:A" & LastRow)
' rws = rng.Rows.Count
'
' For i = rws To 1 Step (-1)
For i = 100 To 1 Step (-1)
If WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).EntireRow.Delete
Next
End Sub
#Harun24HR - Here's how I attempted at solving this problem: I recorded a macro that deletes a row and I edited that macro to do my original question, why doesn't this work, please correct it:
Sub DeleteRowWithEmptyCell()
Dim row As Integer
For row = 1 To 100 'or whatever numbers needed
If Cells(row, 1).Value() = "" Then
Rows("row:row").Select
Selection.Delete Shift:=xlUp
End If
Next row
End Sub
I have written a code which does the below steps.
1) Loops through a list of products
2) Auto filters the data with each product.
3) Copies and pastes data on to separate worksheets and names it with that product name.
4) Inserts a line at every change in schedule
The only thing I couldn't do it here is to limit separate worksheet creation only for the products available in the source data when auto filtered.
I tried to do this by adding an if condition to add worksheets by product name only if auto filter shows any data but for some reason it is not working.
I would appreciate any help in fixing this problem and clean my code to make it look better and work faster.
Sub runreport()
Dim rRange As Range
Dim Rng As Range
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
Next producttype
End Sub
Try this...
Sub runreport()
Dim rRange As Range
Dim Rng As Range
Dim FiltRows As Integer
' Open the Source File
Filename = Application.GetOpenFilename()
Workbooks.Open Filename
'Loops through each product type range from the macro spreadsheet.
For Each producttype In ThisWorkbook.Sheets("Schedule").Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
With Workbooks("Source.xlsx").Sheets("Sheet1")
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
End With
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
Sheets("Sheet1").Select
Sheets("Sheet1").Select
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
'Names the worksheet by Prod type descreption doing a vlookup from the spreadsheet
ActiveSheet.Name = Application.VLookup(producttype, ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
'This will paste the filtered data from Source Data to the new sheet that is added
Range("a2").Select
ActiveSheet.Paste
ns = ActiveSheet.Name
'Copeis the headers to all the new sheets
Sheets("Sheet1").Select
Range("A1:BC1").Select
Selection.Copy
Sheets(ns).Activate
Range("a1").Select
ActiveSheet.Paste
Columns.AutoFit
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
Next producttype
End Sub
I would recommend you define more variables than you have it keeps the code cleaner and easier to read as well as eliminates easy errors.
I also recommend always to utilize "option explicit" at the top of every code. It forces defining all variables (when you don't define a variable the program will do it for you (assuming you haven't used option explicit), but excel doesn't always get it correct. Also option explicit helps you avoid typos in variables.
Also as a general rule you rarely if ever have to .select anything to do what you need to with vba.
Below is an example of a cleaned up and shortened code which utilized variable definition and instantiation.
Sub runreport()
Dim wb As Workbook
Dim wsSched As Worksheet
Dim wsNew As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rRange As Range
Dim producttype As Range
Dim Filename As String
Dim FiltRows As Integer
Dim myRow As Integer
'instantiate Variables
Set wb = ThisWorkbook
Set wsSched = wb.Worksheets("Schedule")
' Open the Source File
Filename = Application.GetOpenFilename()
Set wbSource = Workbooks.Open(Filename)
Set wsSource = wbSource.Worksheets("Sheet1")
'Loops through each product type range from the macro spreadsheet.
For Each producttype In wsSched.Range("Product")
' Filters the sheet with a product code that matches and copy's the active sheet selection
With wsSource
.AutoFilterMode = False
.Range("A1:G1").AutoFilter Field:=4, Criteria1:=producttype
FiltRows = .AutoFilter.Range.Rows.SpecialCells(xlCellTypeVisible).Count / .AutoFilter.Range.Columns.Count
If FiltRows > 1 Then 'There will always be a header row which is why it needs to be greater than one.
'Add new workbook
Set wsNew = wb.Sheets.Add(After:=ActiveWorkbook.Sheets(Sheets.Count))
'Copy filtered data including header
.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
'Paste filterd data and header
wsNew.Range("A1").PasteSpecial
Application.CutCopyMode = False
wsNew.Columns.AutoFit
'Rename new worksheet
wsNew.Name = WorksheetFunction.VLookup(producttype, wb.Worksheets("Sheet2").Range("A:B"), 2, False)
' Inserts a blank row for everychange in ID
myRow = 3
Do Until Cells(myRow, 3) = ""
If Cells(myRow, 3) = Cells(myRow - 1, 3) Then
myRow = myRow + 1
Else
Cells(myRow, 1).EntireRow.Insert
myRow = myRow + 2
End If
Loop
End If
End With
Next producttype
End Sub
First, you can check this answer for ways to optimize your vba code
As for your code in its current form, it would be easiest if you select the entire range of your product code data first. Then you can check this range after your filter and determine if all the rows are hidden. See a sample of the code below
Dim productData as Range
Set productData = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))
' Filters the sheet with a product code that matches and copy's the active sheet selection
Workbooks("Source.xlsx").Sheets("Sheet1").Range("A1:G1").AutoFilter _
Field:=4, Criteria1:=producttype
' The error check will skip the creation of a new sheet if the copy failed (i.e. returns a non-zero error number)
On Error Resume Next
' Copies only the visible cells
productData.SpecialCells(xlCellTypeVisible).Copy
If Err.number = 0 then
'Adds a new workbook
ActiveWorkbook.Sheets.Add After:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = Application.VLookup(producttype, _
ThisWorkbook.Sheets("Sheet2").Range("A:B"), 2, False)
Range("a2").Select
ActiveSheet.Paste
End If
While you can Range.Offset one row and check if the Range.SpecialCells method with xlCellTypeVisible is Not Nothing, I prefer to use the worksheet's SUBTOTAL function. The SUBTOTAL function discards hidden or filtered rows from its operations so a simple COUNTA (SUBTOTAL subfunction 103) of the cells below the header will tell you if there is anything available.
Sub runreport()
Dim rRange As Range, rHDR As Range, rVAL As Range, wsn As String
Dim fn As String, owb As Workbook, twb As Workbook
Dim i As Long, p As Long, pTYPEs As Variant
pTYPEs = ThisWorkbook.Sheets("Schedule").Range("Product").Value2
Set twb = ThisWorkbook
' Open the Source File
fn = Application.GetOpenFilename()
Set owb = Workbooks.Open(fn)
With owb
'is this Workbooks("Source.xlsx")?
End With
With Workbooks("Source.xlsx").Worksheets("Sheet1")
With .Cells(1, 1).CurrentRegion
'store the header in case it is needed for a new worksheet
Set rHDR = .Rows(1).Cells
'reset the the filtered cells
Set rVAL = Nothing
For p = LBound(pTYPEs) To UBound(pTYPEs)
.AutoFilter Field:=4, Criteria1:=pTYPEs(p)
With .Resize(.Rows.Count - 1, 7).Offset(1, 0) '<~~resize to A:G and move one down off the header row
If CBool(Application.Subtotal(103, .Cells)) Then
'there are visible cells; do stuff here
Set rVAL = .Cells
wsn = Application.VLookup(pTYPEs(p), twb.Worksheets("Sheet2").Range("A:B"), 2, False)
'if the wsn worksheet doesn't exist, go make one and come back
On Error GoTo bm_New_Worksheet
With Worksheets(wsn)
On Error GoTo bm_Safe_Exit
rVAL.Copy Destination:=.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'when inserting rows, always work from the bottom to the top
For i = .Cells(Rows.Count, 3).End(xlUp).Row To 3 Step -1
If .Cells(i, 3).Value2 <> .Cells(i - 1, 3).Value2 Then
.Rows(i).Insert
End If
Next i
'autofit the columns
For i = .Columns.Count To 1 Step -1
.Columns(i).AutoFit
Next i
End With
End If
End With
Next p
End With
End With
GoTo bm_Safe_Exit
bm_New_Worksheet:
On Error GoTo 0
With Worksheets.Add(after:=Sheets(Sheets.Count))
.Name = wsn
rHDR.Copy Destination:=.Cells(1, 1)
End With
Resume
bm_Safe_Exit:
End Sub
When a worksheet that is referenced by the wsn string does not exist, the On Error GoTo bm_New_Worksheet runs off and creates one. The Resume brings the code processing right back to the place it errored out.
One caution when using this method is to ensure that you have unique, legal worksheet names returned by your VLOOKUP function.
I need to scan through all of the rows in the "Master" worksheet, find any cells with the value "Shipped" in the column "Status", then cut and paste each entire row to another sheet. The pasted rows need to be placed after the last row also.
I found this post (pasted below) which I slightly modified to delete rows successfully. But I can not figure out how to move rows instead. Should I try an entirely new method?
Sub DeleteRows()
Dim rng As Range
Dim counter As Long, numRows as long
With ActiveSheet
Set rng = Application.Intersect(.UsedRange, .Range("C:C"))
End With
numRows = rng.Rows.Count
For counter = numRows to 1 Step -1
If Not rng.Cells(counter) Like "AA*" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
End Sub
I do not know VBA. I only kind of understand it because of my brief programming history. I hope that is okay and thank you for any help.
There's a couple of ways you could do it, can you add a filter to the top columns, filter by the value of 'Shipped'? Does it need to be copy and pasted into a new sheet?
It's not the most concise code but it might work
sub Shipped_filter()
dim wsSheet as worksheet
dim wsOutputSheet as worksheet
dim BottomRow as integer
Set wsSheet = worksheets("Sheet1") 'change to the sheet name
set wsOutputSheet = worksheets("Sheet2") 'change to the sheet name
'*****************************
'* Delete old data on Sheet2 *
'*****************************
wsoutputsheet.activate
Activesheet.cells.clearall
wsSheet.range("A1").select
selection.autofilter
BottomRow = wsSheet.range("A90000").end(xlup).row ' or another column you guarantee will always have a value
activesheet.range("$A$1:$Z$"&BottomRow).AutoFilter field:=1, Criteria1:="Shipped" ' change field to whatever column number Status is in
'********************************
'* Error trap in case no update *
'********************************
if activesheet.range("A90000").end(xlup).row = 1 then
msgbox("Nothing to ship")
exit sub
end if
wsSheet.range("A1:Z"&Bottomrow).select
selection.copy
wsOutputSheet.range("A1").select
selection.pastespecial Paste:=xlpastevalues
application.cutcopymode = false
msgbox('update complete')
end sub
I haven't tried it so it might need updating
I ended up combining the code I was originally using (found here) with an AutoFilter macro (found here). This is probably not the most efficient way but it works for now. If anyone knows how I can use only the For Loop or only the AutoFilter method that would be great. Here is my code. Any edits I should make?
Sub DeleteShipped()
Dim lastrow As Long
Dim rng As Range
Dim counter As Long, numRows As Long
With Sheets("Master")
'Check for any rows with shipped
If .Range("R:R").Find("Shipped", , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No shipped plates found. ", , "No Rows Moved": Exit Sub
Else
Application.ScreenUpdating = False
'Copy and paste rows
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Worksheets("ShippedBackup").Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A1:U" & lastrow).AutoFilter field:=18, Criteria1:="Shipped"
.Range("A2:U" & lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets("ShippedBackup").Range("A" & lastrow2).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.ShowAllData
'Delete rows with shipped status
Set rng = Application.Intersect(.UsedRange, .Range("R:R"))
numRows = rng.Rows.Count
For counter = numRows To 1 Step -1
If rng.Cells(counter) Like "Shipped" Then
rng.Cells(counter).EntireRow.Delete
End If
Next
MsgBox "All shipped records have been moved to the ""ShippedBackup"" worksheet.", , "Backup Complete"
End If
End With
Hope it helps someone!