I have a VBA function that I am using to copy of list of sheets from active workbook and save it. I am getting subscript out of range error. Any help would be appreciated?
Private Sub exporttoexcel(excelFileName)
excelFileName = 'File in my local'
Dim mySheetList() As String
Dim WS As Worksheets
Dim WB As Workbook
MsgBox excelFileName
'Dim sourceWB As Workbook
'Dim destWB As Workbook
'
'Set sourceWB = ActiveWorkbook
'sourceWB.Sheets.Copy
'
'Set WB = Workbooks(excelFileName)
ReDim mySheetList(0 To (ThisWorkbook.Sheets.Count) - 1)
Dim a As Integer
a = 0
For Each WS In ActiveWorkbook.Worksheets
mySheetList(a) = WS.Name
a = a + 1
Next
Dim Fileobj
Set Fileobj = CreateObject("Scripting.FileSystemObject")
If Fileobj.FileExists(excelFileName) Then
Fileobj.DeleteFile excelFileName
End If
' 'actually save
Worksheets(mySheetList).Copy '<<<<<<< RUN-TIME ERROR 9 RAISED HERE
ActiveWorkbook.SaveAs FileName:=excelFileName
'MsgBox excelFileName
'ThisWorkbook.SaveAs FileName:=excelFileName, FileFormat:=xlXMLSpreadsheet
Application.Wait (Now + TimeValue("0:00:15"))
WB.Close
End Sub
I think you have passed the sheet a list of names of sheets, i.e., "sheet1","sheet2",etc. However, when passing an array the function Sheets(Array(mySheetList)) must be used.
'Worksheets(mySheetList).Copy
Sheets(Array(mySheetList)).Copy
This works for me, I would try adapting somewhat for your excelfilename. There was also a problem with the ws being dimmed as a worksheet. I would use Option Explicit in the future.
Private Sub exporttoexcel()
'excelFileName = 'File in my local'
Dim mySheetList() As String
Dim WS
Dim WB As Workbook
MsgBox excelFileName
'Dim sourceWB As Workbook
'Dim destWB As Workbook
'
'Set sourceWB = ActiveWorkbook
'sourceWB.Sheets.Copy
'
'Set WB = Workbooks(excelFileName)
ReDim mySheetList(0 To (ThisWorkbook.Sheets.count) - 1)
Dim a As Integer
a = 0
For Each WS In ThisWorkbook.Worksheets
mySheetList(a) = WS.Name
a = a + 1
Next
Dim Fileobj
Set Fileobj = CreateObject("Scripting.FileSystemObject")
If Fileobj.FileExists(excelFileName) Then
Fileobj.DeleteFile excelFileName
End If
' 'actually save
Sheets(mySheetList).Copy
ActiveWorkbook.SaveAs Filename:=excelFileName
'MsgBox excelFileName
'ThisWorkbook.SaveAs FileName:=excelFileName, FileFormat:=xlXMLSpreadsheet
Application.Wait (Now + TimeValue("0:00:15"))
WB.Close
End Sub
Related
This question is vaguely similar to renaming multiple worksheets from list using VBA, but is too different to get the answer from that question.
I will regularly need to rename dozens of worksheets in various incoming workbooks.
I wish to rename all worksheets by first copying all the worksheet names into a secondWorkbook.sheets(1) colA, manually creating new names in ColB, and then run a second macro to update the names in the originalWorkbook.
I am stuck on the second macro, but will provide both macros below. If anyone has a shorter/better way of writing these macros, I am all eyes.
First macro - copy all worksheet names into a new workbook.sheet(1).colA. This works, and creates a new unsaved workbook with the tab names in ColA
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim tst, tmp, allTabNames As String
Dim i, cnt, cnt2 As Long
Dim wb, wbTmp As Workbook, xWs, ws1 As Worksheet
Dim arrOldNames, arrNewNames As Variant
ReDim arrOldNames(999)
cnt = 0
With ActiveWorkbook
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
arrOldNames(cnt) = xWs.Name
cnt = cnt + 1
End If
Next
End With
ReDim Preserve arrOldNames(cnt - 1)
cnt2 = 1
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
For i = 1 To cnt
ws1.Range("A" & i).Value = arrOldNames(i - 1)
Next
MsgBox "Done. Copied " & cnt & " tab names."
End Sub
Here is the macro I am stuck on. Both workbooks are open on screen, and I don't mind editing the macro to provide the workbook names. Unsure how to reference an unsaved workbook with a name like "Book4 - Microsoft Excel", so I have been saving it as Temp.xlsx and referencing it as namesWb. The workbook with the tabs to be renamed is referenced as targetWb
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb, targetWb As Workbook
Dim colA, colB As Variant
Set namesWb = Windows("Temp.xlsx")
Set targetWb = ActiveWorkbook
ReDim colA(999), colB(999)
cnt = 0
With namesWb
Sheets(1).Activate
For i = 1 To 999
If Range("A" & i).Value = "" Then Exit For
colA(i - 1) = Range("A" & i).Value
colB(i - 1) = Range("B" & i).Value
cnt = cnt + 1
Next
ReDim Preserve colA(cnt)
ReDim Preserve colB(cnt)
End With
For each oldname in colA()
'Stuck here...
Next
End Sub
I realize that I could again loop through the targetWb and, for each tabname, find the location of that tabname in ColA() and rename it with the same position name from tabB() - but I am wondering if there is a faster/better way to do this.
You can loop through active workbooks like this:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name Like "Book*" Then
Set tempWB = wb
End If
Next wb
End Sub
Edit: Since you only have two open workbooks, you can shorten that:
Sub t()
Dim mainWB As Workbook, tempWB As Workbook
Dim wb As Workbook
Set mainWB = ActiveWorkbook ' MAKE SURE THIS IS CORRECT!! May need `ThisWorkbook` if the new temporary one becomes the active one.
For Each wb In Application.Workbooks
'Loops through the workbooks.
Debug.Print wb.Name
If wb.Name <> mainWB.Name And wb.Name <> "PERSONAL.XLSB" Then
Set tempWB = wb
' Now do whatever you need with the Temporary workbook.
End If
Next wb
End Sub
I've refactored both your Sub's to show a more robust method.
Dim all variables, with explicit types (some of yours were defaulting to Variant)
Record the Workbook being processed in the top of the Names list
Still processes the ActiveWorkbook
Save the Temp workbook into the same folder as ActiveWorkbook
Rename... now skips any missing new names
Detect missing OldNames (see comment in code, place any response you want there)
Detect failed Renames (eg could be invalid characters in the new names)
Sub GrabAllTabNamesIntoTempWorkbookColA()
Dim wbToRename As Workbook
Dim wbTmp As Workbook
Dim xWs As Worksheet
Dim ws1 As Worksheet
Dim arrOldNames As Variant
Dim arrNewNames As Variant
Dim cnt As Long
Set wbToRename = ActiveWorkbook
With wbToRename
' Size array based on number of sheets in workbook
ReDim arrOldNames(1 To .Worksheets.Count, 1 To 1)
cnt = 0
For Each xWs In .Worksheets
If xWs.Visible = xlSheetVisible Then
cnt = cnt + 1
arrOldNames(cnt, 1) = xWs.Name
End If
Next
End With
Set wbTmp = Workbooks.Add
Set ws1 = wbTmp.Sheets(1)
'Place data in sheet in one go
ws1.Cells(1, 1) = wbToRename.Name
ws1.Cells(2, 1).Resize(UBound(arrOldNames, 1), 1) = arrOldNames
MsgBox "Done. Copied " & cnt & " tab names."
'Save workbook
wbTmp.SaveAs Filename:=wbToRename.Path & "\Temp", FileFormat:=xlOpenXMLWorkbook
End Sub
Sub RenameAllTabsFromColAInTempWorkbook()
Dim namesWb As Workbook
Dim targetWb As Workbook
Dim wsNames As Worksheet
Dim ws As Worksheet
Dim NamesList As Variant
Dim cnt As Long
Dim i As Long
Set namesWb = Application.Workbooks("Temp.xlsx")
Set targetWb = Application.Workbooks(namesWb.Worksheets(1).Cells(1, 1).Value)
cnt = 0
Set wsNames = namesWb.Worksheets(1)
With wsNames
'Get Names into one variable, based on actual number of rows
NamesList = wsNames.Range(wsNames.Cells(2, 2), wsNames.Cells(wsNames.Rows.Count, 1).End(xlUp)).Value
For i = 1 To UBound(NamesList, 1)
' Check if the Name has been entered
If NamesList(i, 2) <> vbNullString Then
'Get reference to sheet by old name, and handle if sheet is missing
Set ws = Nothing
On Error Resume Next
Set ws = targetWb.Worksheets(NamesList(i, 1))
On Error GoTo 0
' Rename sheet
If Not ws Is Nothing Then
On Error Resume Next
ws.Name = NamesList(i, 2)
On Error GoTo 0
If ws.Name <> NamesList(i, 2) Then
' Rename failed! What now?
End If
Else
'Sheet Missing! What now?
End If
End If
Next
End With
End Sub
Sub Testing()
Dim Target_Workbook As Workbook
Dim Source_Workbook As Workbook
Dim Target_Path As String
Target_Path = "Sample.xlsx"
Set Target_Workbook = Workbooks.Open(Target_Path)
Set Source_Workbook = ThisWorkbook
Source_data = Source_Workbook.Sheets(1).Range("A1:Y74").Copy
Target_Workbook.Sheets(1).Range("A1").Activate
Source_Workbook.Save
Target_Workbook.Save
Target_Workbook.Close False
MsgBox "Task Completed"
End Sub
use below code, populate your source and target excel file names and call this code
Sub CopyWorkbook(Sourceworkbook, TargetWorkbook)
Dim sh As Worksheet, wb As Workbook, wbSource As Workbook
Dim SourcefileName As String
SourcefileName = Sourceworkbook
Set wbSource = Workbooks.Open(Sourceworkbook)
Set wb = Workbooks(TargetWorkbook)
For Each sh In Workbooks(SourcefileName).Worksheets
sh.Copy After:=wb.Sheets(wb.Sheets.count)
Next sh
wbSource.Close
End Sub
e.g TargetWorkbook = "TwoSheet_Compare V2.0.xlsm" and
SourceWorkbook = "sourceFile.xlsx"
Sub NapiMaker()
Dim wb As Workbook
Set wb = ActiveWorkbook
Debug.Print wb.Name
Dim MyFile As String
If MyFile = "" Then
MyFile = Application.GetOpenFilename()
Workbooks.Open (MyFile)
wb.Activate
Dim WS_Count As Integer
Dim I As Integer
WS_Count = wb.Worksheets.Count
For I = 1 To WS_Count
wb.Worksheets(I).Range("B7").Copy Workbooks(MyFile).Worksheets(1).Range("A16")
wb.Worksheets(I).Range("B8").Copy Workbooks(MyFile).Worksheets(1).Range("B16")
wb.Worksheets(I).Range("B10").Copy Workbooks(MyFile).Worksheets(1).Range("D16")
wb.Worksheets(I).Range("B11").Copy Workbooks(MyFile).Worksheets(1).Range("J16")
wb.Worksheets(I).Range("B5").Copy Workbooks(MyFile).Worksheets(1).Range("F16")
wb.Worksheets(I).Range("B14").Copy Workbooks(MyFile).Worksheets(1).Range("E16")
Workbooks(MyFile).Worksheets("1").Range("A16").EntireRow.Insert
Next I
End If
End Sub
I want to the the following:
- I open a file.
- Press CRTL+K.
- Lets me choose a file.
- Copy the specified cells to the chosen file.
I can't find the problem.
It's under the For loop
The filename passed as an index to the Workbooks collection appears to not allow the path to be included. (I was sure I had seen somewhere that it could be.) Therefore Workbooks("abcdef.xlsx") would work, but Workbooks("C:\Temp\abcdef.xlsx") will not.
The following code will assign a Workbook object to the opened workbook, and then use that object to refer to it in subsequent statements, therefore avoiding the need to use an index into the Workbooks collection.
Sub NapiMaker()
Dim wb As Workbook
Dim wb1 As Workbook
Set wb = ActiveWorkbook
Debug.Print wb.Name
Dim MyFile As String
If MyFile = "" Then ' myFile will always be blank at this point
MyFile = Application.GetOpenFilename()
Set wb1 = Workbooks.Open(MyFile)
Dim WS_Count As Integer
Dim I As Integer
WS_Count = wb.Worksheets.Count
For I = 1 To WS_Count
wb.Worksheets(I).Range("B7").Copy wb1.Worksheets(1).Range("A16")
wb.Worksheets(I).Range("B8").Copy wb1.Worksheets(1).Range("B16")
wb.Worksheets(I).Range("B10").Copy wb1.Worksheets(1).Range("D16")
wb.Worksheets(I).Range("B11").Copy wb1.Worksheets(1).Range("J16")
wb.Worksheets(I).Range("B5").Copy wb1.Worksheets(1).Range("F16")
wb.Worksheets(I).Range("B14").Copy wb1.Worksheets(1).Range("E16")
'Changed "1" to 1
wb1.Worksheets(1).Range("A16").EntireRow.Insert
Next I
End If
End Sub
This is my code for copying a sheet to new sheet.
When I ran the program with breakpoint on Workbooks.Open(path) it was working correctly but when I ran without the breakpoint it simply opened the workbook without creating any sheet.
I have tried my best to rectify the error but I couldn't get the desired result.
Sub CopyCat()
Dim ws As Worksheet
Dim no As Integer
Set ws1 = ActiveSheet
Dim path As String
temp_name = InputBox("Enter the Sheet No to be Created", "Enter the Value")
For Loop1 = 1 To ws1.UsedRange.Rows.Count
path = Application.ActiveWorkbook.path & "\" & Application.WorksheetFunction.Trim(Trim(ws1.Cells(Loop1, 1).Value)) & " " & ws1.Cells(Loop1, 2).Value & ".xlsx"
Set wb1 = Workbooks.Open(path)
'ListBox1.AddItem wb.Name
temp_name = "Sheet" & temp_name
'error1 = CheckSheet(wb1, temp_name)
'If (error1 <> True) Then
ws1.Cells(4, 1).Value = "Created" & CStr(Loop1)
Set ws = wb1.Worksheets(Sheets.Count)
ws.Copy After:=wb1.Sheets(Sheets.Count)
Set ws = ActiveSheet
ws.Name = temp_name
'Call PageSetting
wb1.Close SaveChanges:=True
ws1.Cells(4, 1).Value = "Created Done" & CStr(Loop1)
'Else
'wb1.Close SaveChanges:=True
'End If
Next Loop1
End Sub
Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In wb.Sheets
If oSheet.Name = sSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
This question is a bit vague, so i assumed a few things based on the code you provided.
You want to copy a worksheet from a workbook that runs the macro to another excel file.
All file names are listed in the source worksheet, column A - let's call it "Interface" worksheet.
You will need to add reference to Microsoft Scripting Runtime in your project for the FileSystemObject to work.
Code below isnt wery well written or optimised, yet it works.
Sub CopySht(NamesRange As Range, NameOfSheetToCopy As String)
Dim fso As FileSystemObject, oFile As File, fPath As String, fNamesArr() As Variant, fFolder As Folder
Set fso = New FileSystemObject
Dim InputWb As Workbook, InterfaceWs As Worksheet
Set InputWb = ThisWorkbook
Set InterfaceWs = InputWb.Worksheets("Interface")
Dim SheetToCopy As Worksheet
Set SheetToCopy = InputWb.Worksheets(NameOfSheetToCopy)
Set NamesRange = InterfaceWs.Range(NamesRange.Address)
fNamesArr() = NamesRange.Value
fPath = InputWb.path
Set fFolder = fso.GetFolder(fPath)
Dim i As Integer
For Each oFile In fFolder.Files
For i = LBound(fNamesArr) To UBound(fNamesArr)
If oFile.Name = fNamesArr(i, 1) & ".xls" Or oFile.Name = fNamesArr(i, 1) & ".xlsx" Then
On Error Resume Next
If Not (Workbooks(oFile.Name) Is Nothing) Then
Workbooks(oFile.Name).Close SaveChanges:=False
End If
Workbooks.Open (oFile.path)
If Not (CheckSheet(Workbooks(oFile.Name), SheetToCopy.Name)) Then
SheetToCopy.Copy After:=Workbooks(oFile.Name).Sheets(1)
Workbooks(oFile.Name).Close SaveChanges:=True
End If
If Not (Workbooks(oFile.Name) Is Nothing) Then
Workbooks(oFile.Name).Close SaveChanges:=False
End If
End If
Next i
Next oFile
End Sub
Function CheckSheet(ByVal wb As Workbook, ByVal sSheetName As String) As Boolean
Dim oSheet As Excel.Worksheet
Dim bReturn As Boolean
For Each oSheet In wb.Sheets
If oSheet.Name = sSheetName Then
bReturn = True
Exit For
End If
Next oSheet
CheckSheet = bReturn
End Function
It doesnt matter if you pass NamesRange as qualified or unqualified range object, as shown below
Sub Wrapper()
CopySht Range("A1:A6"), "CopyMe"
'CopySht ThisWorkbook.Worksheets("Interface").Range("A1:A6"), "CopyMe"
End Sub
The Excel hang if the user click the button in the sheet. The button allowed the user to run the following VBA code. If the user runs the code from VBA editor, it's working fine. Kindly help. The code is as the following. I'm trying to copy data from current excel file to the other excel file newly created.
Sub clickBreak()
i = 12
Dim workBookName As String
Dim workBookName2 As String
Dim wb2 As Workbook
Dim wb1 As Workbook
Dim pasteStart As Range
workBookName = Application.ActiveWorkbook.FullName
workBookName2 = Insert(workBookName, "_2", InStr(workBookName, ".xls") - 1) & ".xls"
MsgBox workBookName2
Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile workBookName, workBookName2, True
Set xlobj = Nothing
Set wb1 = Workbooks.Open(Filename:=workBookName)
Set pasteStart = [A12:A15]
wb1.Sheets("contents").Range("A12:A15").Copy
Set wb2 = Workbooks.Open(Filename:=workBookName2)
wb2.Sheets("contents").Range("A12:A:15").PasteSpecial xlPasteAll
wb2.Save
End Sub
clickBreak is not an event handler. If the name of your button is Break you must name the sub
BreaK_Click() for it to act as an event handler for the button click event:
Sub BreaK_Click()
...
End Sub
Full Code:
Sub BreaK_Click()
i = 12
Dim workBookName As String
Dim workBookName2 As String
Dim wb2 As Workbook
Dim wb1 As Workbook
Dim pasteStart As Range
workBookName = Application.ActiveWorkbook.FullName
workBookName2 = Insert(workBookName, "_2", InStr(workBookName, ".xls") - 1) & ".xls"
MsgBox workBookName2
Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile workBookName, workBookName2, True
Set xlobj = Nothing
Set wb1 = Workbooks.Open(Filename:=workBookName)
Set pasteStart = [A12:A15]
wb1.Sheets("contents").Range("A12:A15").Copy
Set wb2 = Workbooks.Open(Filename:=workBookName2)
wb2.Sheets("contents").Range("A12:A:15").PasteSpecial xlPasteAll
wb2.Save
End Sub
I got the answer
Sub clickBreak()
Dim workBookName As String
Dim workBookName2 As String
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Set wbThis = ActiveWorkbook
strName = ActiveSheet.Name
workBookName = Application.ActiveWorkbook.FullName
workBookName2 = Insert(workBookName, "_2", InStr(workBookName, ".xls") - 1) & ".xls"
Dim xlobj As Object
Set xlobj = CreateObject("Scripting.FileSystemObject")
xlobj.CopyFile workBookName, workBookName2, True
Set xlobj = Nothing
Set wbTarget = Workbooks.Open(workBookName2)
wbTarget.Sheets("contents").Range("A1").Select
wbTarget.Sheets("contents").Range("A12:A15").ClearContents
wbThis.Activate
Application.CutCopyMode = False
wbThis.Sheets("contents").Range("A12:A15").Copy
wbTarget.Sheets("contents").Range("A12:A15").PasteSpecial
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
wbThis.Activate
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
Thanks you for spending time on my question and giving feedback. Sorry for answering my own question, I just want to share my resolution with the other who will be having the same problem.
I got reference from this http://en.kioskea.net/faq/24666-excel-vba-copy-data-to-another-workbook