I have written a macro to create a variable number of worksheets based on a list in worksheet "ProjList". Each sheet is named at the time of creation. I am trying to copy the values in some of the cells (Columns A-D) from "ProjList" to the new sheets. I've successfully done it with with a paste command, but I want the data transposed.
I have written:
Sub AddWorkSheets()
Dim RowNumb As Long
Dim LastRow As Integer
LastRow = Worksheets("ProjList").Cells(Worksheets("ProjList").Rows.Count, "D").End(xlUp).Row
For RowNumb = 2 To LastRow
Sheets("ProjList").Activate
Worksheets("ProjList").Range("A" & RowNumb, "D" & RowNumb).Copy
Sheets.Add
ActiveSheet.Name = Worksheets("ProjList").Cells(RowNumb, 4).Value
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Range("D1").PasteSpecial Paste:=xlPasteValues, transpose:=True
Next RowNumb
End Sub
I get a
RunTime Error 1004: PasteSpecial method of range class failed.
The first worksheet gets created, but the macro fails at the PasteSpecial line.
Any help is much appreciated.
Thank you!
Try This:
ActiveSheet.Range("D1").Resize(, 4).PasteSpecial Paste:=xlPasteValues, transpose:=True
try this code bellow:
Sub AddWorkSheets()
Dim RowNumb As Long
Dim LastRow As Integer
LastRow = Worksheets("ProjList").Cells(Worksheets("ProjList").Rows.Count, "D").End(xlUp).Row
For RowNumb = 2 To LastRow
Sheets("ProjList").Activate
Sheets.Add
ActiveSheet.Name = Worksheets("ProjList").Cells(RowNumb, 4).Value
ActiveSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
ActiveSheet.Range("D1").Resize(, 4) = Application.WorksheetFunction.Transpose(Worksheets("ProjList").Range("A" & RowNumb, "D" & RowNumb))
Next RowNumb
End Sub
Related
I am using the following code:
Sub CSVParser()
Dim i As Integer
Dim x As Integer
Dim values As Range
Sheets("CSV Paste").Select
Range("A3").Select
For i = 1 To Range("A3", Range("A3").End(xlDown)).Rows.Count
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Working Sheet 1").Select
Range("A1").Select 'problem code
Do Until ActiveCell.Value = ""
If ActiveCell.Value = "" Then
Exit Do
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
ActiveSheet.Paste
Sheets("CSV Paste").Select
ActiveCell.Offset(1, 0).Select
Next
End Sub
However, the line Range("A1").Select just after Sheets("Working Sheet 1").Select is kicking up a run-time error '1004'
Does anyone know why? I have rearranged this in every way I can think of an have typed it out from scratch again.
Give this version of your code a try:
Sub CSVParser()
Dim wb As Workbook
Dim wsCSV As Worksheet
Dim wsWork As Worksheet
Set wb = ActiveWorkbook
Set wsCSV = wb.Sheets("CSV Paste")
Set wsWork = wb.Sheets("Working Sheet 1")
wsCSV.Range("A3").CurrentRegion.Copy wsWork.Cells(wsWork.Cells.Count, "A").End(xlUp).Offset(1)
End Sub
Using .Select and .Activate is not considered 'best practice'. See How to avoid using Select in Excel VBA macros. Yes, using the code from the macro recorder is a good place to start but you have to get away from the practice at some point.
Performing bulk operations is preferred to looping through an indeterminate number of rows or columns.
Option Explicit
Sub CSVParser()
Dim lastCol As Long
With Worksheets("CSV Paste")
With .Range(.Cells(3, "A"), .Cells(.Rows.Count, "A").End(xlUp))
lastCol = .CurrentRegion.Columns.Count
With .Resize(.Rows.Count, lastCol)
.Copy Destination:=Sheets("Working Sheet 1").Range("A1")
End With
End With
End With
End Sub
I think this is what you are trying to achieve (without all the unnecessary Select):
Option Explicit
Sub CSVParser()
Dim i As Long
Dim x As Long
Dim LastRow As Long
Dim PasteRow As Long
With Sheets("CSV Paste")
LastRow = .Range("A3").End(xlDown).Row
For i = 3 To LastRow
PasteRow = Sheets("Working Sheet 1").Cells(Sheets("Working Sheet 1").Rows.Count, "A").End(xlUp).Row
.Range(.Range("A" & i), .Range("A" & i).End(xlToRight)).Copy Destination:=Sheets("Working Sheet 1").Range("A" & PasteRow + 1)
Next i
End With
End Sub
I am using this code to check each row in worksheet "Report2" for the phrase "Chicago" and copy and paste any rows with "Chicago" in them into a new sheet. However, it is not working. Any help on why would be appreciated.
Code:
Sub BranchCount()
Dim s As Worksheet
Dim LastRow As Long
Set s = Worksheets("Report 1")
LastRow = s.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Worksheets("Report 1").Select
Range("A1:J" & LastRow).Select
Selection.Copy
Sheets.Add.Name = "Report2"
Selection.PasteSpecial xlPasteValues
Range("A1").EntireRow.Delete
Range("B1").EntireRow.Delete
Range("C1").EntireRow.Delete
Dim Z As Range
Dim Y As String
Y = W
W = "Chicago"
Sheets("Report2").Range("A1").Select
For Each Z In Range("J1:J" & LastRow)
If Y = Z.Value Then
Z.EntireRow.Copy
Sheets("Clean").Select
Range("A700").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Report2").Select
End If
Next
End Sub
Let me know if you can help. Thanks!
no need for any helper ("Report2") sheet
you could filter the relevant part of data cells and copy selected cells directly to "Clean" sheet as follows
Option Explicit
Sub BranchCount()
Dim s1 As Worksheet, sC As Worksheet
Dim LastRow As Long
Set s1 = Worksheets("Report 1")
Set sC = Sheets("Clean")
With s1
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
With .Range("A1:J" & LastRow)
.AutoFilter field:=10, Criteria1:="Chicago"
With .Offset(1).Resize(.Rows.Count - 1)
If Application.WorksheetFunction.Subtotal(103, .Columns("J")) > 1 Then .SpecialCells(xlCellTypeVisible).Copy Destination:=sC.Range("A700").End(xlUp).Offset(1, 0)
End With
.AutoFilter
End With
End With
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
I have a column with unknown number of rows in one sheet, i'd like to copy it and paste on another sheet. As far number of rows is unknown I define it as a variable:
Sub Official()
Dim lastrow As Long
Dim LastCol As Long
Set currentsheet = ActiveWorkbook.Sheets(1)
LastRow = Range("A65536").End(xlUp).Row
LastCol = Range("A1").End(xlToRight).Column
Sheets("Type_1").Range("D8" & "D" & LastRow).Copy
Sheets(1).Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub
I get an error to this macro, maybe someone can help me?
you could try:
Sub Official()
Dim lastrow As Long
Dim LastCol As Long
Dim srcLastRow As Long
Set currentsheet = ActiveWorkbook.Sheets(1)
' handle Office 2007+ with more than 65536 rows...
lastrow = Range("A" & currentsheet.Rows.Count).End(xlUp).Row
LastCol = Range("A1").End(xlToRight).Column
' find out how many rows there are in the source sheet
srcLastRow = Sheets("Type_1").Range("D" & Sheets("Type_1").Rows.Count).End(xlUp).Row
' copy from the course sheet to the currentSheet in the range specified
Sheets("Type_1").Range("D8:" & "D" & srcLastRow).Copy Destination:=currentsheet.Range("A" & lastrow)
' or maybe you want:
' Sheets("Type_1").Range("D8:" & "D" & srcLastRow).Copy Destination:=currentsheet.Cells(lastrow, LastCol)
End Sub
This should be simple but I am having a tough time.. I want to copy the cells A3 through E3, and paste them into the next empty row on a different worksheet. I have used this code before in longer strings of code.. but i had to tweak it and it is not working this time. I get a "application-defined or object-defined error" when i run the code seen below. All help is appreciated.
Private Sub CommandButton1_Click()
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).row
Range("A3:E3").Copy Destination:=Sheets("Summary Info").Range("A:A" & lastrow)
End Sub
Be careful with the "Range(...)" without first qualifying a Worksheet because it will use the currently Active worksheet to make the copy from. It's best to fully qualify both sheets. Please give this a shot (please change "Sheet1" with the copy worksheet):
EDIT: edited for pasting values only based on comments below.
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet2")
copySheet.Range("A3:E3").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
The reason the code isn't working is because lastrow is measured from whatever sheet is currently active, and "A:A500" (or other number) is not a valid range reference.
Private Sub CommandButton1_Click()
Dim lastrow As Long
lastrow = Sheets("Summary Info").Range("A65536").End(xlUp).Row ' or + 1
Range("A3:E3").Copy Destination:=Sheets("Summary Info").Range("A" & lastrow)
End Sub
You could also try this
Private Sub CommandButton1_Click()
Sheets("Sheet1").Range("A3:E3").Copy
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).Row
Sheets("Summary Info").Activate
Cells(lastrow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub
Below is the code that works well but my values overlap in sheet "Final" everytime the condition of <=11 meets in sheet "Calculator"
I would like you to kindly support me to modify the code so that the cursor should move to next blank cell and values keeps on adding up like a list.
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Calculator")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Final")
For i = 2 To ws1.Range("A65536").End(xlUp).Row
If ws1.Cells(i, 4) <= 11 Then
ws2.Cells(i, 1).Value = Left(Worksheets("Calculator").Cells(i, 1).Value, Len(Worksheets("Calculator").Cells(i, 1).Value) - 0)
ws2.Cells(i, 2) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:D"), 4, False)
ws2.Cells(i, 3) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:E"), 5, False)
ws2.Cells(i, 4) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:B"), 2, False)
ws2.Cells(i, 5) = Application.VLookup(Cells(i, 1), Worksheets("Calculator").Columns("A:C"), 3, False)
End If
Next i