similar questions have been asked but I think I have a different problem:
Workbooks.Open Filename:=filepath & "PLT.xlsx"
Worksheets("Sheet1").Range(Worksheets("Sheet1").Range("A1:B1"), Worksheets("Sheet1").Range("A1:B1").End(xlDown)).Copy
Windows("XXX.xslm").Activate
w1.Range("A4").PasteSpecial Paste:=xlPasteValues
The second line is the problem. In fact, it does not copy the cells I want. When I open that workbook, the whole worksheet is selected.
I do not understand why I get that error.
Yikes. If you want to copy values to it the easy way:
Global fso As New FileSystemObject
Public Sub CopyValuesTest()
' Get references to the files
Dim wb1 As Workbook, wb2 As Workbook
Set wb1 = Workbooks.Open(fso.BuildPath(filepath, "PLT.xlsx"))
Set wb2 = Workbooks("XXX")
' Get references to the sheets
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = wb1.Sheets("Sheet1")
Set ws2 = wb2.Sheets("Sheet1")
' Count non-empty rows under A1. Use 2 columns
Dim N As Integer, M As Integer
N = CountRows(ws1.Range("A1")): M = 2
' This copies the values
ws2.Range("A4").Resize(N, M).Value = ws1.Range("A1").Resize(N, M).Value
End Sub
Public Function CountRows(ByRef r As Range) As Long
If IsEmpty(r) Then
CountRows = 0
ElseIf IsEmpty(r.Offset(1, 0)) Then
CountRows = 1
Else
CountRows = r.Worksheet.Range(r, r.End(xlDown)).Rows.Count
End If
End Function
And make sure your filepath is defined. Also to use FileSystemObject see https://stackoverflow.com/a/5798392/380384
Related
I am trying to copy the data from one workbook to another workbook.
I searched through Internet and came up with the below code. there is no error in the code.
The code works fine, but the Problem is, it is opening both the Sheets , but not copying the data in Destination sheet.
in the code below, I have considered x as source sheet and y as Destination sheet.
Could someone suggest, where i am wrong and what is the reason i am not able to copy.
Sub test()
Dim x As Workbook
Dim y As Workbook
Dim val As Variant
Dim filename As String
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")
Set y = Sheets("Sheet1").Select
val = x.Sheets("Sheet2").Range("A1").Value
y.Sheets("Sheet1").Range("A1").Value = val
x.Close
End Sub
The reason for your error, lies in the section below:
Dim y As Workbook
Set y = Sheets("Sheet1").Select
You defined y as workbook, but trying to assign a Worksheet object to it, and you added Select for some reason, which is defiantly not recommended.
It should be (if the workbook is open) :
Set y = Workbooks("YourBookName")
The rest of your code would work just fine.
However, reading your post, I think you meant to define y As Worksheet.
And then the rest of your code should be:
Set y = Sheets("Sheet1")
val = x.Sheets("Sheet2").Range("A1").Value
y.Range("A1").Value = val
Edit 1: Updated code (according to PO's new data)
Option Explicit
Sub test()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")
Val = x.Sheets("Sheet2").Range("A1").Value
y.Sheets("Sheet1").Range("A1").Value = Val
x.Close
End Sub
Edit 2: Code to copy columns A:E till last row with data
Option Explicit
Sub test()
Dim x As Workbook
Dim y As Workbook
Dim Val As Variant
Dim filename As String
Dim LastCell As Range
Dim LastRow As Long
Set y = ThisWorkbook ' set ThisWorkbook object (where this code lies)
Set x = Workbooks.Open("D:\Mikz\xxx.xlsx")
With x.Sheets("Sheet2")
' use the find method to get the last row in column A:E
Set LastCell = .Columns("A:E").Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then ' find was successful
LastRow = LastCell.Row ' get last Row with data
End If
Val = .Range("A1:E" & LastRow).Value ' save range in 2-D array
End With
' resize the range from A1 through column E and the last row with data in copied workbook
y.Sheets("Sheet1").Range("A1").Resize(LastRow, 5).Value = Val
x.Close
End Sub
Try:
Sub test()
Dim wb As Workbook
Dim sht As Worksheet, sht2 As Worksheet
Set wb = Workbooks.Open("Filename")
Set sht = wb.Worksheets("Sheet2")
Set sht2 = ThisWorkbook.Worksheets("Sheet1")
sht2.Range("A1").Value = sht.Range("A1").Value
wb.Close
End Sub
But it should throw syntax errors and type mismatches before. Dont use .Select, its not necessary for any functions or task, it can be done without.
I have a workbook with a master sheet for school report cards. I have a macro applied to a button for exporting information from the master sheet to separate, newly-generated sheets in the same workbook. A1:C71 is the template and goes to every new sheet, and the following columns of info, from D1:71 to Q1:71, each appear in separate sheets (always in D1:71).
Here's the screenshot (http://imgur.com/a/ZDOVb), and here's the code:
`Option Explicit
Sub parse_data()
Dim studsSht As Worksheet
Dim cell As Range
Dim stud As Variant
Set studsSht = Worksheets("Input")
With CreateObject("Scripting.Dictionary")
For Each cell In studsSht.Range("D7:Q7").SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(cell.Value) = .Item(cell.Value) & cell.EntireColumn.Address(False, False) & ","
Next
For Each stud In .keys
Intersect(studsSht.UsedRange, studsSht.Range(Left(.Item(stud), Len(.Item(stud)) - 1))).Copy Destination:=GetSheet(CStr(stud)).Range("D1")
Next
End With
studsSht.Activate
End Sub
Function GetSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(shtName)
If GetSheet Is Nothing Then
Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))
GetSheet.Name = shtName
Sheets("Input").Range("A1:C71").Copy
GetSheet.Range("A1:D71").PasteSpecial xlAll
GetSheet.Range("A1:B71").EntireColumn.ColumnWidth = 17.57
GetSheet.Range("C1:C71").EntireColumn.ColumnWidth = 54.14
GetSheet.Range("D1:D71").EntireColumn.ColumnWidth = 22
End If
End Function`
I would now like to create a separate button to split the sheets into separate workbooks so that the master sheet can be kept for record keeping and the individual workbooks can be shared with parents online (without divulging the info of any kid to parents other than their own). I would like the workbooks to be saved with the existing name of the sheet, and wonder if there's a way to have the new workbooks automatically saved in the same folder as the original workbook without having to input a path name? (It does not share the same filename as any of the sheets).
I tried finding other code and modifying it, but I just get single blank workbooks and I need as many as have been generated (preferably full of data!), which varies depending on the class size. Here's the pathetic attempt:
`Sub split_Reports()
Dim splitPath As String
Dim w As Workbook
Dim ws As Worksheet
Dim i As Long, j As Long
Dim lastr As Long
Dim wbkName As String
Dim wksName As String
Set wsh = ThisWorkbook.Worksheets(1)
splitPath = "G:\splitWb\"
Set w = Workbooks.Add
For i = 1 To lastr
wbkName = ws
w.Worksheets.Add(After:=w.Worksheets(Worksheets.Count)).Name = ws
w.SaveAs splitPath
w.Close
Set w = Workbooks.Add
Next i
End Sub`
I have learned so much, and yet I know so little.
Maybe this will start you off, just some simple code to save each sheet as a new workbook. You would probably need some check that the sheet name is a valid file name.
Sub x()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
ws.Copy
ActiveWorkbook.Close SaveChanges:=True, Filename:=ws.Name & ".xlsx"
Next ws
End Sub
I open two Workbooks that are part of the a 3D CAD file and have not real path.
Anyway, after I open them manually I want VBA to move, say, A1 from Workbook B To Workbook A.
In order for VBA to know the name of the source, I say the name of Workbook B is stored in B1 of Workbook A
I know how to move data if I have a path but since there is "none", how do I do that? Thank you!
Hope this help.
Dim FrmWorkbook As Workbook
Dim iCount As Integer
'Capture the source workbook
For i = 1 To ThisWorkbook.Application.Workbooks.Count
'change the name of your source Workbook below
If ThisWorkbook.Application.Workbooks(i).Name = "Book1.xlsx" Then
Set FrmWorkbook = ThisWorkbook.Application.Workbooks(i)
Exit For
End If
Next
'option 1: row by row or column by colum. (Column C)
Dim lRow As Long
For lRow = 1 To 100
ThisWorkbook.Sheets(1).Range("C" & lRow).Value = FrmWorkbook.Sheets(1).Range("C" & lRow).Value
Next
'option 2: copy the entire sheet (assuming Sheet1)
With FrmWorkbook.Sheets(1)
.Activate
.Select
.Copy before:=ThisWorkbook.Sheets(1)
End With
Set FrmWorkbook = Nothing
MsgBox "DONE"
After going back and forth i found out that this works too:
Private Sub import_Click()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set wb2 = ActiveWorkbook
Set ws2 = wb2.Sheets("sheet1")
Set wb1 = Workbooks(ActiveSheet.Range("n2").Value & ".xls")
Set ws1 = wb1.Sheets("input")
ws2.Range("a1") = ws1.Range("f90").Value
End Sub
Thank you for the good ideas
I am trying to create a macro that will copy actual sheet and name it with next letter of the alphabet. First sheet "A" always exists in the workbook, other sheets (B, C, D, etc.) will be added as necessary. I managed to put together the following piece of code that can create sheet "B". Issue is that when copying sheet "B", I get Run-time error '1004' indicating error on the last line of code.
Sub newList()
' New_List Macro
Dim PrevLetter As String
PrevLetter = "ActiveSheet.Name"
ActiveSheet.Copy after:=ActiveSheet
ActiveSheet.Name = Chr(Asc(PrevLetter) + 1)
End Sub
Can anyone of you help?
Your code is giving an error as Soren mentioned.
However your code will give an error if sheet "A" is active after creation of "B" as sheet "B" already exists.
You might want to try this? for this, it's not important which sheet is active. Also this code will let you create sheets beyond Z. So sheets after Z will be named as AA, AB etc..
Using this code, In XL2007+ you can create sheets up till XFD (more 16383 sheets)
Using this code, In XL2003 you can create sheets up till IV (more 255 sheets)
CODE:
Sub newList()
Dim PrevLetter As String
Dim ws As Worksheet, wsNew As Worksheet
Dim wsname As String
Set ws = ThisWorkbook.Sheets("A")
ws.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set wsNew = ActiveSheet
wsname = GetNewName
wsNew.Name = wsname
End Sub
Function GetNewName() As String
Dim NewWs As Worksheet
For i = 2 To ThisWorkbook.Sheets(1).Columns.Count
ColName = Split(ThisWorkbook.Sheets(1).Cells(, i).Address, "$")(1)
On Error Resume Next
Set NewWs = ThisWorkbook.Sheets(ColName)
If Err.Number <> 0 Then
GetNewName = ColName
Exit For
End If
Next i
End Function
You should simply write your code like this instead:
Sub newList()
' New_List Macro
Dim PrevLetter As String
PrevLetter = ActiveSheet.Name '<--- Change made to this line
ActiveSheet.Copy after:=ActiveSheet
ActiveSheet.Name = Chr(Asc(PrevLetter) + 1)
End Sub
EDIT: This is not a "best practice code" answer. This just points out what in your own code were returning the error. The other answers to this question (so far) are indeed much more sophisticated and correct ways of solving this problem.
Here is another way you could do this:
Sub newList()
' New_List Macro
Dim PrevLetter As String
Dim wb As Workbook
Dim ws1 As Worksheet
Set wb = ActiveWorkbook
Set ws1 = wb.ActiveSheet
PrevLetter = ws1.Name
ws1.Copy After:=ws1
Sheets(Sheets.Count).Name = Chr(Asc(PrevLetter) + 1)
Set wb = Nothing
Set ws1 = Nothing
End Sub
I have the following which errors on the "rTemp.Value = vaTemp" line. What am I doing wrong here? Am I on the right track?
Function CreateTempRange(rSource As range) As range
' Declarations
Dim rTemp As range
Dim vaTemp As Variant
Dim wsTemp As Worksheet
Dim wbTemp As Workbook
' Open temp worksheet
Set wbTemp = Workbooks.Add
Set wsTemp = wbTemp.Worksheets.Add
' Copy range into it and get a reference to the temp range
vaTemp = rSource.Value
Set rTemp = wsTemp.range("A1").Resize(UBound(vaTemp, 1), UBound(vaTemp, 2))
rTemp.Value = vaTemp
' Return the temp range
Set CreateTempRange = rTemp
End Function
Note: This function is intended to be used by other functions and not called directly from a cell.
Set rTemp = wsTemp.range("A1").Resize(UBound(vaTemp, 1), UBound(vaTemp, 2)
There'll be a type mismatch here ... i'm not sure it really makes any sense. ubound(a,2) is used for multi-dimensional arrays not ranges.
I'm guessing you want to take the value in the cell specified then copy it many times depending on it's value. Is that correct?
Hopefully the below should give you an example to work with. If not edit your post and i'll see if i can help.
Function CreateTempRange(rSource As Range) As Range
'' Declarations
Dim rTemp As Range
Dim vaTemp As Variant
Dim wsTemp As Worksheet
Dim wbTemp As Workbook
'' Open temp worksheet
Set wbTemp = Workbooks.Add
Set wsTemp = wbTemp.Worksheets.Add
'' Copy range into it and get a reference to the temp range
vaTemp = rSource.Value
''Set rTemp = wsTemp.Range("A1").Resize(UBound(vaTemp, 1), UBound(vaTemp, 2))
Dim iTemp As Integer
On Error Resume Next
iTemp = CInt(vaTemp)
On Error GoTo 0
If iTemp < 1 Then
iTemp = 1
End If
Set rTemp = wsTemp.Range("A1:A" & iTemp)
rTemp.Value = vaTemp
'' Return the temp range
Set CreateTempRange = rTemp
End Function
Sub test()
Dim r As Range
Dim x As Range
Set r = ActiveSheet.Range("A1")
Set x = CreateTempRange(r)
End Sub
vaTemp = rSource.Value
As you aren't specifying the RangeValueDataType parameter to the Value method of the Range object, it will default to xlRangeValueDefault which, for non-empty ranges, will return an array of values. Therefore, the UBound(..., 1) and UBound(..., 2) parts make sense.
This would be easier:
Function CreateTempRange(rSource As range) As range
' Declarations
Dim rTemp As range
Dim wsTemp As Worksheet
Dim wbTemp As Workbook
' Open temp worksheet
Set wbTemp = Workbooks.Add
Set wsTemp = wbTemp.Worksheets.Add
' Create new range on that sheet starting at cell A1
Set rTemp = wsTemp.Range(Cells(1, 1), Cells(rSource.Rows.Count, _
rSource.Columns.Count))
rTemp.Value = rSource.Value
' Return the temp range
Set CreateTempRange = rTemp
End Function
You would still need some code to deal with ranges which consist of multiple areas (use the Areas.Count property to check for that)
I would do it like this
Function CreateTempRange(src As Range) As Range
Dim wbk As Workbook: Set wbk = Workbooks.Add
Dim sht As Worksheet: Set sht = wbk.Worksheets.Add
Call src.Copy(sht.Cells(1, 1))
Set CreateTempRange = Range(rSource.Address).Offset(1 - rSource.Row, 1 - rSource.Column)
End Function
Explanation of the last line of code (as requested):-
Range(rSource.Address) - this refers to the range on the current worksheet (containing the code) with the same local address as the source range, so if the the source range is C3:E5 on 'Sheet X' then Range(rSource.Address) refers to C3:E5 on the current sheet.
Since we pasted the copied range into the current sheet starting at cell A1 rather than cell C3 (I assume this is your requirement), we then need to offset this reference accordingly. The .Offset(1 - rSource.Row, 1 - rSource.Column) offsets this range negatively by both the row index (3) minus 1 and column index (C or 3) minus 1 of the source range, so that the final resulting reference starts with cell A1 and keeps the same dimensions as the source range.
Hope that helps.
Deano, that code works for me as written. What is the error you're getting?