When I compile this script, macro confuses the range sometimes and I get error 1004 saying copy paste area can't be same even though I paste it in a different sheet. Appreciate if someone can let me know where I am going wrong
Dim LastRow1 As Long
With Worksheets("1")
LastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:EE" & LastRow1).Copy
End With
Worksheets("3").Activate
Range("A1").PasteSpecial Transpose:=True
MsgBox ("Transpose Completed")
I will suggest checks and updates to your macro as below.
Sub TransposeData()
Dim LastRow1 As Long
With Worksheets("1")
LastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
If LastRow1 > 16384 Then
MsgBox "Transpose not possible, number of columns will be exceeded!", vbExclamation
Exit Sub
End If
.Range("A1:EE" & LastRow1).Copy
End With
Worksheets("3").Range("A1").PasteSpecial Transpose:=True
Application.CutCopyMode = False
MsgBox ("Transpose Completed")
End Sub
Related
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
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 have tried some of the codes suggested for similar macros.
I need the information in the cells in column L to be individually pasted as pictures in column M. I don't want to manually do this over and over for each of the hundreds of items.
Here is what it looks like without a loop or a repeat. Just doing the operation twice.
Sub pasteaspicture()
pasteaspicture Macro
Range("L3").Select
Selection.Copy
Range("M3").Select
ActiveSheet.Pictures.Paste.Select
Range("L4").Select
Application.CutCopyMode = False
Selection.Copy
Range("M4").Select
ActiveSheet.Pictures.Paste.Select
End Sub
Thanks.
This code should loop from row 3 to end of column L, if that is not what you want then I can edit it for you.
Application.screenupdating = False
With ActiveSheet
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
End With
For i = 3 To LastRow
Range("L" & i).Copy
Range("M" & i).Select
ActiveSheet.Pictures.Paste.Select
Next i
Application.screenupdating = true
This code should work, but it includes a select, which is unwanted in VBA but since I have no clue how to use picture paste I used your code as a template.
Here is a quick (but long) way to do it without loops.
It sets ranges and finds the last row of the Column.
You will find Excel has many ways to skin the same nut. Hope this helps.
Sub CopyPic()
Dim lTopRow As Long
Dim lLeftColumn As Long
Dim lRightColumn As Long
Dim lLastRow As Long
With Sheets("Sheet1")
lTopRow = .Range("L3").Row
lLeftColumn = .Range("L3").Column
lLastRow = .Range("L:L").Find("*", , xlValues, , xlByRows, xlPrevious).Row
lRightColumn = lLeftColumn
Application.Goto .Range(Cells(lTopRow, lLeftColumn), Cells(lLastRow, lRightColumn)), scroll:=False
Selection.Copy
lLeftColumn = .Range("M3").Column
lRightColumn = lLeftColumn
Application.Goto .Range(Cells(lTopRow, lLeftColumn), Cells(lLastRow, lRightColumn)), scroll:=False
.Pictures.Paste.Select
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 an excel spreadsheet with 75 tabs-- each tab is formatted in the same way with two columns of words. I want all of this data to be on just a single page, but I don't know how to programmatically extract tables from each tab and paste it on a single tab.
Is there a way to do this in Excel?
Alright, here's the code that I've tried:
Sub Macro5()
Range("A1:B30").Select
Selection.Copy
Sheets("Table 1").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
End Sub
All tabs are formatted in the same way, with data in all cells from A1:B30. I'm thinking that the Selection.End command would go to the next available open cell and paste data from the subsequent tabs in that.
As of current, I would need to go to each tab and individually run this macro, except that it doesn't work because it says the pasted data is not of the same type/format of the existing data.
Any ideas?
Coding attempt #2- SUCCESS!!!
Sub Macro5()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.activate
Range("A1:B30").Select
Selection.Copy
Sheets("Table 1").Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
On Error Resume Next 'Will continue if an error results
Next ws
End Sub
Well, I hate to admit I'm glad you didn't just spoonfeed me the answer. Good on you, sir.
Coding Attempt #3- Avoid Selections
Sub Macro5()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Set Rng = ws.Range("A1:B30")
Rng.Copy
Dim ws1 As Worksheet
Set ws1 = Worksheets("Table 1")
ws1.Select
Selection.End(xlDown).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
On Error Resume Next 'Will continue if an error results
Next ws
End Sub
Not quite right-- it still works, but I'm not sure how to avoid using "Selection" when I get to the first workbook. Is there a way to reference the most proximate cell without content? I know the 'End' key can do this, but is there a non-selection based way?
See this code.
I modified your code so that it doesn't use .Select or .Activate at all.
I have commented the code so you shouldn't have a problem understanding it. :)
The code doesn't use On Error Resume Next. You should always avoid that unless it is necessary. Use proper error handling instead. Consider On Error Resume Next as telling your application to simply SHUT UP. :)
Here is an example of basic error handling
Sub Sample()
On Error GoTo Whoa
'
'~~> Rest of Code
'
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
So this is how your final code will look like. It avoids the use of .Select or .Activate. It also avoids the use of Selection and finds the exact range that needs to be copied and exact range where it needs to be copied. Also it does proper error handling.
Option Explicit
Sub Sample()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim rng As Range
Dim LRowO As Long, LRowI As Long
On Error GoTo Whoa
'~~> Set your Output Sheet
Set wsOutput = ThisWorkbook.Sheets("Table 1")
'~~> Loop through all sheets
For Each wsInput In ThisWorkbook.Worksheets
'~~> Ensure that we ignore the output sheet
If wsInput.Name <> wsOutput.Name Then
'~~> Working with the input sheet
With wsInput
'~~> Get the last row of input sheet
LRowI = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range for copying
Set rng = .Range("A1:B" & LRowI)
'~~> Copy your range
rng.Copy
'~~> Pasting data in the output sheet
With wsOutput
'~~> Get the next available row in output sheet for pasting
LRowO = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'~~> Finally paste
.Range("A" & LRowO).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End With
End If
Next wsInput
Exit Sub
Whoa:
MsgBox Err.Description
End Sub