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
Related
I am basically copying one excel file sheet to a particular sheet of the excel file(same file as where I am writing the macro).I get the error- Run time error '9': Subscript out of range on the line WbTarget.Sheets("FPP").Range("A1:E654").PasteSpecial
I am not that good in VBA-any help please?
Sub XMLR()
Dim output As String
output = CreateObject("WScript.Shell").Exec("R CMD BATCH filepath.R").StdOut.ReadAll
Call XML
End Sub
Sub XML()
Dim wbTarget
Dim wbThis
Dim strName
Set wbThis = Workbooks.Open("file.xlsx")
wbThis.Activate
strName = ActiveSheet.Name
Set wbTarget = ActiveWorkbook
Application.CutCopyMode = False
wbThis.Sheets("Sheet1").Range("A1:E654").Copy
wbTarget.Sheets("FPP").Range("A1:E654").PasteSpecial
Application.CutCopyMode = False
wbTarget.Save
wbTarget.Close
wbThis.Close
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
Slightly confusing, but try this:
Sub XML()
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Set wbThis = Workbooks.Open("file.xlsx")
ThisWorkbook.Sheets("FPP").Range("A1:E654").Value = wbThis.Sheets("Sheet1").Range("A1:E654").Value
wbTarget.Save
wbTarget.Close
wbThis.Close
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
The issue here is that both WbTarget and WbThis refer to the same workbook.
You should change you declaration:
Set wbTarget = ActiveWorkbook
to
Set wbTarget = Application.ThisWorkbook
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"
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
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
I'm trying to open a workbook and delete a sheet from it, but it runs the code without errors, and the sheet is still there...
I'm able to modify it, as I changed formulas to values on another sheet.
First of all - Yes, I know the "i" variable is set to do 1 iteration.
Somehow, now when I open the workbook it says it's locked by me - which I don't even know how to do.
So...how can I unlock it? When I go to File-->Info-->Permissions it says 'Anyone can copy, change and modify any part of this workbook.... I can delete the sheet manually as well...
Here's the code:
Sub Change()
Dim wb As Excel.Workbook
Set wb = ThisWorkbook
Dim ws As Excel.Worksheet
Set ws = wb.Sheets("FileSearch Results")
Dim rng As Range
Set rng = ws.UsedRange
Dim cPaths As Integer
cPaths = rng.Column
Dim i As Integer
i = rng.Row
Dim oExcel As Excel.Application
Set oExcel = New Excel.Application
Dim oWB As Workbook
Dim komm As Excel.Worksheet
Dim sh1 As Excel.Worksheet
Do While i < 2
Dim pth As String
pth = ws.Cells(i, cPaths)
Set oWB = oExcel.Workbooks.Open(pth)
Set sh1 = oWB.Worksheets("Sheet1")
With sh1.UsedRange
.Value = .Value
End With
Set komm = oWB.Worksheets("Kommentar")
Application.DisplayAlerts = False
komm.Delete
Application.DisplayAlerts = True
oWB.Close savechanges:=True
i = i + 1
Loop
End Sub
Any ideas?
Sub Change()
Dim wb As Excel.Workbook
Set wb = ActiveWorkbook 'ThisWorkbook
Dim ws As Excel.Worksheet
Set ws = wb.Sheets("FileSearch Results")
Dim rng As Range
Set rng = ws.UsedRange
Dim cPaths As Integer
cPaths = rng.Column
Dim i As Integer
i = rng.row
'Dim oExcel As Excel.Application ***CHANGED***
'Set oExcel = New Excel.Application ***CHANGED***
'Dim oWB As Workbook ***CHANGED***
Dim komm As Excel.Worksheet
Dim sh1 As Excel.Worksheet
Do While i < 2
Dim pth As String
pth = ws.Cells(i, cPaths)
'Set oWB = oExcel.Workbooks.Open(pth) ***CHANGED***
Workbooks.Open (pth) '***ADDED***
Set sh1 = ActiveWorkbook.Worksheets("Sheet1") 'oWB.Worksheets("Sheet1") ***CHANGED***
With sh1.UsedRange
.Value = .Value
End With
Set komm = ActiveWorkbook.Worksheets("Kommentar") 'oWB.Worksheets("Kommentar") ***CHANGED***
Application.DisplayAlerts = False
komm.Delete
Application.DisplayAlerts = True
ActiveWorkbook.Close savechanges:=True 'oWB.Close savechanges:=True ***CHANGED***
i = i + 1
Loop
End Sub
This now opens the workbook and deletes the sheet in the foreground rather than invoking a new instance of Excel and deleting the sheet in the background. This is why the file stays locked, as the new instance which isn't closed by the code, still holds it.
For anyone running into this in the future (like myself), the actual problem is with the mix up in scope when calling Application.DisplayAlerts.
komm is a sheet in oWB, which exists in the new instance of excel oExcel.
Application is a completely different instance and therefor has no effect.
Since the code isn't actually disabling the prompt in the correct instance of excel (oExcel) and it is presumably not visible, the code will just ignore the command and move on.
The simple fix is to use oExcel instead of Application:
Set komm = oWB.Worksheets("Kommentar")
oExcel.DisplayAlerts = False
komm.Delete
oExcel.DisplayAlerts = True