I'm writing VBA in Excel and I have a cell with some numbers in it and I have a "shopping cart" range and I when I click on the button I want to copy the cell value to the "cart" but if the first row in the cart is already full it should move on the next row and do this until it finds a row that it empty and paste it in there.
I tried to do it but got a problem
Sub Gumb1_Klikni()
Range("B1").Select
Selection.Copy
Range("J2").Select
If IsEmpty(ActiveCell) Then
Selection.PasteSpecial xlPasteAll
Else
Set nextcell = ActiveCell.Offset(1, 0)
Range(nextcell).Select
ActiveSheet.Paste
End If
End Sub
It gives me Error 1004 "Method 'Range' of object '_Global' failed" at
Range(nextcell).Select
If you would define Dim nextcell as Range at the beginning of your Sub , all you need to do is:
nextcell.Select
However, you could use the "Cleaner" version below, without the need to use Select or Selection :
Option Explicit
Sub Gumb1_Klikni()
Dim nextCell As Range
Range("B1").Copy
If IsEmpty(Range("J2")) Then
Range("J2").PasteSpecial xlPasteAll
Else
Set nextCell = Range("J2").Offset(1, 0)
nextCell.PasteSpecial
End If
End Sub
Edit 1: after PO clarification:
Sub Gumb1_Klikni()
Dim LastRow As Long
' get last row with data in column "J"
LastRow = Cells(Rows.Count, "J").End(xlUp).Row
If LastRow < 1 Then LastRow = 1
Range("B1").Copy
Range("J" & LastRow + 1).PasteSpecial xlPasteAll
End Sub
Related
New to VBA and simply wanted to create a macro which copies the tables within a specified range and pastes in the next available empty rows. What happens is that every time I run it it pastes into the same range i.e. B12 and don't know how to amend...
Sub CopyRange2()
Range("A1:I9").Select
Selection.Copy
Range("B12").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Would like to know why you have specified cell B12 ??
The below code will work if you just want to paste the data in the next available empty rows.
Sub CopyRange2()
Dim lastrow As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:I9").Select
Selection.Copy
Range("A" & lastrow + 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
So I am trying to create a macro that will autofilter a range of data (in Column E) for predefined headers that start at Column N. So the autofilter runs filtering the data in column e for the title in column n, it then copies and pastes that data into column n, then loops and does the same for column o and so on. The issue I am having, is if the filter runs, and there are no matches for the autofilter it creates an error. Strangely, I used if error go to, and for one blank column it works perfectly, however if there are two blank columns as such, then it fails the second time around. I have posted the code below. Does anyone have any suggestions?
Sub Siglum_Sorter()
Sheets("Operator Database").Select
Dim rRng1 As Range
Dim rRng2 As Range
Dim fCol As Long
fCol = 13
Set rRng1 = Range("E:E")
Set rRng2 = Range("G2:G100")
Do
On Error GoTo SkipToHere
fCol = fCol + 1
rCrit = Cells(1, fCol)
MsgBox "cells " & fCol & " " & rCrit
With rRng1
.AutoFilter field:=1, Criteria1:=rCrit, Operator:=xlOr
rRng2.SpecialCells(xlCellTypeVisible).Copy 'or do something else
End With
Cells(2, fCol).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
SkipToHere:
Loop Until IsEmpty(Cells(1, fCol))
End Sub
Dim rngF As Range
With rRng1.AutoFilter field:=1, Criteria1:=rCrit, Operator:=xlOr
Set rngF = Nothing
On Error Resume Next 'ignore any error if no visible cells
Set rngF = rRng2.SpecialCells(xlCellTypeVisible)
On Error Goto 0
If Not rngF Is Nothing Then
'do something with rngF
Else
'no visible cells...
End If
I would just add a a check after the filter to see if the last visible row is the data headers. If so, don't copy the data
Dim lrow_data as long
lrow_data = ThisWorkbook.Sheets("Sheet1").Cells(Cells.Rows.Count,1).End(xlUp) 'or change it to your needed sheet
If lrow_data = 1 Then
'Do Nothing, last row is the headers
Else
rRng2.SpecialCells(xlCellTypeVisible).Copy
End If
I want to create a logical range based on the location of where the program finds the string.
sample Workbook
What I am attempting:
This sample workbook will have a column of dates and a column of statuses per sheet. Each sheet will also have another column to the right of the "status" column that simply outputs the word "Current" for that date. (If this is redundant and you would rather search for the current date in that first column that shows all the dates, feel free to ignore this. I only put it in to make it simple for me.)
This program needs to search in the column to the right of the status column for the string "current" and copy and paste that "status" cells value adjacent to it (or just locate the address via the rows date and run the sub for that specific row's "Status" cell if you wanted to ignore the "current" string thing). The Sample will not have the actual formulas in the status cells and only the values I put in for reference but it is the same principle.
Sub Ruby()
If Sheets("ALPHA").Range("T2:T5000").Value = "Current" Then
Sheets("ALPHA").Select
Call copy
End If
If Sheets("BRAVO").Range("T2:T5000").Value = "Current" Then
Sheets("BRAVO").Select
Call copy
End If
If Sheets("CHARLIE").Range("T2:T5000").Value = "Current" Then
Sheets("CHARLIE").Select
Call copy
End If
End Sub
Sub copy()
'
' copy Macro
'
'
Range("S98").Select
Selection.copy
Range("S98").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
From what your code looks like, you want to change the formula in Column S to a value.
You can loop through each sheet and make it happen
Sub RubyLoop()
Dim sh As Worksheet, LstRw As Long
Dim rng As Range, c As Range
For Each sh In Sheets
With sh
LstRw = .Cells(.Rows.Count, "T").End(xlUp).Row
Set rng = .Range("T2:T" & LstRw)
For Each c In rng.Cells
If c = "Current" Then c.Offset(, -1).Value = c.Offset(, -1).Value
Next c
End With
Next sh
End Sub
With end if
Sub RubyLoop2()
Dim sh As Worksheet, LstRw As Long
Dim rng As Range, c As Range
For Each sh In Sheets
With sh
LstRw = .Cells(.Rows.Count, "T").End(xlUp).Row
Set rng = .Range("T2:T" & LstRw)
For Each c In rng.Cells
If c = "Current" Then
c.Offset(, -1).Value = c.Offset(, -1).Value
End If
Next c
End With
Next sh
End Sub
I have the following VBA code that takes a single row from Sheet "Tabled data", copies the data, then pastes the data into the next available row in Sheet "Running list". However the original row has formulas and I need the values to paste, not the formulas. I've seen numerous ways to do it with Range.PasteSpecial but this code didn't use Range and I'm not sure how to incorporate it.
Note: I modified this code from here: http://msdn.microsoft.com/en-us/library/office/ff837760(v=office.15).aspx. It originally had an IF statement to match content in a cell then paste it in a certain sheet according to the content in the cell. I only had one sheet to copy to and didn't need the IF. I don't really need to find the last row of data to copy either as it will only ever be one row with range of A2:N2. But if I take out the FinalRow section and the For and replace with Range("A2:N2") it doesn't work so I left those in.
Any guidance on how to add in the PasteValues property without making this more complicated? I'm also open to simplification of the For or FinalRow variable such as using Range. I'm only sort of familiar with VBA, having done a few things with it, but usually after much searching and modifying code.
Public Sub CopyData()
Sheets("Tabled data").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
ThisValue = Cells(x, 1).Value
Cells(x, 1).Resize(1, 14).Copy
Sheets("Running list").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Tabled data").Select
Next x
End Sub
Hopefully we can actually make this more simple.
Public Sub CopyRows()
Sheets("Sheet1").UsedRange.Copy
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'check if the last cell found is empty
If IsEmpty(ActiveSheet.Cells(lastrow, 1)) = True Then
'if it is empty, then we should fill it
nextrow = lastrow
Else
'if it is not empty, then we should not overwrite it
nextrow = lastrow + 1
End If
ActiveSheet.Cells(nextrow, 1).Select
ActiveSheet.Paste
End Sub
edit: I expanded it a little so that there won't be a blank line at the top
I found a working solution. I recorded a macro to get the paste special in there and added the extra code to find the next empty row:
Sub Save_Results()
' Save_Results Macro
Sheets("Summary").Select 'renamed sheets for clarification, this was 'Tabled data'
'copy the row
Range("Table1[Dataset Name]").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
' paste values into the next empty row
Sheets("Assessment Results").Select
Range("A2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Return to main sheet
Sheets("Data Assessment Tool").Select
End Sub
Just copy the data all at once, no need to do it a row at a time.
Sub CopyData()
With ThisWorkbook.Sheets("Tabled data")
Dim sourceRange As Range
Set sourceRange = .Range(.Cells(2, 1), .Cells(getLastRow(.Range("A1").Parent), 14))
End With
With ThisWorkbook.Sheets("Running list")
Dim pasteRow As Long
Dim pasteRange As Range
pasteRow = getLastRow(.Range("A1").Parent) + 1
Set pasteRange = .Range(.Cells(pasteRow, 1), .Cells(pasteRow + sourceRange.Rows.Count, 14))
End With
pasteRange.Value = sourceRange.Value
End Sub
Function getLastRow(ws As Worksheet, Optional colNum As Long = 1) As Long
getLastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
End Function
Private Sub Load_Click()
Call ImportInfo
End Sub
Sub ImportInfo()
Dim FileName As String
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim ActiveListWB As Workbook
Dim check As Integer
'Application.ScreenUpdating = False
Set WS2 = ActiveWorkbook.Sheets("KE_RAW")
confirm = MsgBox("Select (.xlsx) Excel file for Data transfer." & vbNewLine & "Please ensure the sheets are named Sort List, Second and Third.", vbOKCancel)
If confirm = 1 Then
FileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select Active List to Import", MultiSelect:=False)
If FileName = "False" Then
MsgBox "Import procedure was canceled"
Exit Sub
Else
Call CleanRaw
Set ActiveListWB = Workbooks.Open(FileName)
End If
Set WS1 = ActiveListWB.Sheets("Sort List")
WS1.UsedRange.Copy 'WS2.Range("A1")
' WS2.Range("A1").Select
WS2.UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'WS2.Range ("A1")
ActiveWorkbook.Close False
'Call ClearFormulas
' Call RefreshAllPivotTables
Sheets("Key Entry Data").Select
'Sheets("Raw").Visible = False
'Application.ScreenUpdating = True
MsgBox "Data has been imported to workbook"
Else
MsgBox "Import procedure was canceled"
End If
Application.ScreenUpdating = True
End Sub
Sub CleanRaw()
Sheets("KE_RAW").Visible = True
Sheets("KE_RAW").Activate
ActiveSheet.Cells.Select
Selection.ClearContents
End Sub
Need a code snippet; if some kind guru could help, please. I need to express the following cursor movement sequence in XL VBA.
After entering a formula in cell A1 (Col-A is otherwise empty), I need to copy the formula to all cells in the range A1:AN, where N is the last row of the table.
I recorded a macro to do the following (code below):
1) enter the formula (in Cell A1)
2) copy the formula
3) go Right to B1
4) go to the last populated cell in Col-B [using Ctrl+Down] (easiest way to find the last row)
5) go Left to Col-A
6) select all cells from current to A1
7) paste the formula to the selection
The part I need help with is a way to capture the cell address in step 5 as a variable so that I can use this macro on a series of files having a variable number of rows.
Here is the recorded macro. In this example, the last row in the table is 7952.
Sub test()
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],3)"
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, -1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveCell.Offset(-7951, 0).Range("A1:A7951").Select
ActiveCell.Activate
ActiveSheet.Paste
End Sub
Kindly copy the below code to the worksheet.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
If Target.Address = "$A$1" And Target.Count = 1 And Target.HasFormula Then
Dim lastRow As Long
lastRow = Range("A65000").End(xlUp).Row
Dim rng As Range
Set rng = Range("A2:A" & lastRow)
' Target.Copy
' rng.PasteSpecial xlPasteFormulas
'OR
' rng.Formula = Target.Formula
' OR
rng.FormulaR1C1 = Target.FormulaR1C1
End If
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
I'm not sure if your end cell is always going to be the same, meaning you may want to "un" hard code the rows, but you could try this.
Sub test()
Range(Cells(1, 1), Cells(7951, 1)) = "=LEFT(RC[1],3)"
End Sub
If you are always going to put equations in column A based on the number of rows used in column B you could try this.
Sub test()
' dimension the variable type
Dim lastRow As Long
' select cell "B1"
Cells(1, 2).Select
' jump to the last consecutive row in column B
Selection.End(xlDown).Select
' collect the row number into a variable
lastRow = ActiveCell.Row
' paste the equation into the variable length range
Range(Cells(1, 1), Cells(lastRow, 1)) = "=LEFT(RC[1],3)"
End Sub
Thanks Todd and user2063626,
I decided on a simpler approach. I only needed to obtain the last row in order to set my selection area; the number of the last row is not used in the actual values to be written. The files to be manipulated are flat ascii exports; the column layout is constant, only the number of rows is variable.
After writing the formula to A1, I move down column B and test for a value one cell at a time; if TRUE, copy the formula to the left adjacent cell; if FALSE, end process.
Sub FillClientCodes()
Range("A1").Select
ActiveCell.FormulaR1C1 = "=LEFT(RC[1],3)"
ActiveCell.Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(1, 0).Select
CheckCell:
ActiveCell.Activate
If ActiveCell.Value <> 0 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Activate
ActiveSheet.Paste
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset(1, 0).Select
GoTo CheckCell
Else: GoTo EndOfData
End If
EndOfData:
End Sub
It's not elegant - it runs slower than a single select and paste - but it works, and it will work on all the files I need to process. Thanks again.