Error: "Method 'rows' of object '_Global' failed - vba

For some reason even though I am referring to the oSheet variable it is returning the error as if I am referring to a global variable?
PS I am trying to populate a combobox in word with a contractor names from an excel sheet I have created. I searched in google and here, none of the solutions have worked for me unfortunately. I believe the error lies within the For Each statement.
Sub Macro3()
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Dim oSheet As Excel.Worksheet
Dim oRng As Excel.Range
Dim ExcelWasNotRunning As Boolean
Dim WorkbookToWorkOn As String
'specify the workbook to work on
WorkbookToWorkOn = "C:\Users\Nathan\Desktop\KTC\VBA Experiment\Excel Files\testExcel.xlsx"
'If Excel is running, get a handle on it; otherwise start a new instance of Excel
On Error Resume Next
Set oXL = GetObject(, "Excel.Application")
If Err Then
ExcelWasNotRunning = True
Set oXL = New Excel.Application
End If
On Error GoTo Err_Handler
'If you want Excel to be visible, you could add the line: oXL.Visible = True here; but your code will run faster if you don't make it visible
'Open the workbook
Set oWB = oXL.Workbooks.Open(FileName:=WorkbookToWorkOn)
'Process each of the spreadsheets in the workbook
For Each oSheet In oXL.ActiveWorkbook.Worksheets
'put guts of your code here
'get next sheet
If oSheet.Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
lastRow = 2
Else
lastRow = oSheet.Cells(Rows.Count, 1).End(xlUp).Row
End If
' For i = 2 To lastRow
' workZonerForm.contracterCMB.AddItem oSheet.Cells(i, 1)
' Next i
MsgBox lastRow
Next oSheet
If ExcelWasNotRunning Then
oXL.Quit
End If
'Make sure you release object references.
Set oRng = Nothing
Set oSheet = Nothing
Set oWB = Nothing
Set oXL = Nothing
'quit
Exit Sub
Err_Handler:
MsgBox WorkbookToWorkOn & " caused a problem. " & Err.Description, vbCritical, _
"Error: " & Err.Number
If ExcelWasNotRunning Then
oXL.Quit
End If
End Sub

Related

VBA Excel --> PWP - Blank when copy

I have a little issue with my macro. I know it's not the perfect one but at least it works.
The only thing is that when I go step by step it is going perfectly but when I run it all the new slides are blank.
Do you have an idea how to improve that ?
Sub paste_toPPT()
Dim PowerPointApp As Object
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(Class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject(Class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
Windows("KPI List - P2P KPI.xlsm").Activate
count = WorksheetFunction.CountA(Sheets("KPI List").Range("E:E")) - 1
For i = 8 To count
Worksheets("KPI List").Select
'ThisWorkbook.Sheets("KPI List").Select
IDe = Worksheets("KPI List").Range(Cells(i, 5), Cells(i, 5))
ThisWorkbook.Sheets("ID").Range("F4:F4") = IDe
'Set the range to copy
Windows("KPI List - P2P KPI.xlsm").Activate
Worksheets("ID").Select
Worksheets("ID").Shapes.Range(Array("Group 57")).Select
Selection.Copy
'Add slide & Paste data
pptPres.Windows(1).Activate
Set mySlide = pptPres.Slides.Add(1, 12)
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.SaveAs DestinationPPT
End Sub
Try the code below, explanations inside the code as comments:
Sub paste_toPPT()
Dim pptApp As Object
Dim pptPres As Object
Dim myRange As Excel.Range
Dim path As String
Dim DestinationPPT As String
Dim saveName As String
Dim image As Object
Dim IDe As String
Dim count As Integer
' added 2 worksheet objects
Dim wsKPI As Worksheet
Dim wsID As Worksheet
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set pptApp = GetObject(, "PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Open template
DestinationPPT = "C:\Users\user\Desktop\ID Card\Kpi ID.pptx"
Set pptPres = pptApp.Presentations.Open(DestinationPPT)
' no need to Activate the workbook first, just set the worksheet objects
Set wsKPI = Workbooks("KPI List - P2P KPI.xlsm").Sheets("KPI List")
Set wsID = Workbooks("KPI List - P2P KPI.xlsm").Sheets("ID")
count = WorksheetFunction.CountA(ws.Range("E:E")) - 1
For i = 8 To count
IDe = wsKPI.Range(wsKPI.Cells(i, 5), wsKPI.Cells(i, 5))
wsID.Range("F4:F4") = IDe
' first add the slide , later do the copy>>paste as close as can be
Set mySlide = pptPres.Slides.Add(1, 12)
' Set the range to copy (no need to Select first)
wsID.Shapes.Range(Array("Group 57")).Copy
mySlide.Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
Next i
pptPres.Save
End Sub

Reopening recently closed instances of Excel

If I use the below code to close all instances of Excel that are currently open what would I need to use to reopen all the instances of Excel that were just closed? I know I'll have to change the below to save a filepath somewhere but just not sure what the actual code should be.
Public Sub CloseAllExcel()
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
wb.Save
wb.Close
Next
xl.Quit
Set xl = Nothing
Loop
Exit Sub
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
This stores file paths of the workbooks to a text file. If you run this macro with False as the input, this will open all of the recently closed files. (Not tested)
Public Sub CloseAllExcel(Closing As Boolean)
On Error GoTo handler
Dim xl As Excel.Application
Dim wb As Excel.Workbook
Dim strPath As String
strPath = "C:\path.txt"
If Close Then
Dim fso as Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile as Object
Set oFile = FSO.CreateTextFile(strPath)
Do While xl Is Nothing
Set xl = GetObject(, "Excel.Application")
For Each wb In xl.Workbooks
oFile.WriteLine Application.ActiveWorkbook.FullName
wb.Save
wb.Close
Next
oFile.Close
Set fso = Nothing
Set oFile = Nothing
xl.Quit
Set xl = Nothing
Loop
Exit Sub
Else
Dim FileNum As Integer
Dim DataLine As String
FileNum = FreeFile()
Open strPath For Input As #FileNum
While Not EOF(FileNum)
Line Input #FileNum, DataLine
Workbooks.Open DataLine
Wend
Exit Sub
End If
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
You could use a Very-Hidden worksheet, where you'll keep all of the Files currently open.
Note: If you want there is an option to Save and Read for the Registry.
Sub CloseAllExcel Code:
Option Explicit
Public Sub CloseAllExcel()
On Error GoTo handler
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim Hidws As Worksheet
On Error Resume Next
Set Hidws = ThisWorkbook.Worksheets("Admin")
On Error GoTo 0
If Hidws Is Nothing Then ' check if there isn't "Admin" sheet exists in the workbook
Set Hidws = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Worksheets(Worksheets.Count))
Hidws.Name = "Admin"
Hidws.Visible = xlSheetVeryHidden ' make the "Admin" sheet very-hidden
End If
i = 1
Do While xlApp Is Nothing
Set xlApp = GetObject(, "Excel.Application")
For Each wb In xlApp.Workbooks
Hidws.Range("A" & i).Value = wb.FullName ' save each workbook full name and path in column "A" in "Admin" very-hidden sheet
i = i + 1
wb.Close True
Next
xlApp.Quit
Set xlApp = Nothing
Loop
Exit Sub
handler:
If Err <> 429 Then 'ActiveX component can't create object
MsgBox Err.Description, vbInformation
End If
End Sub
Sub RestoreExcelLastSession Code: reads the files (names and Path) from Column "A" in "Admin" very-hidden sheet.
Sub RestoreExcelLastSession()
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim Hidws As Worksheet
On Error Resume Next
Set Hidws = ThisWorkbook.Worksheets("Admin")
On Error GoTo 0
If Hidws Is Nothing Then ' check if "Admin" sheet exists
MsgBox "No Files have been restored"
Exit Sub
End If
i = 1
Do While Hidws.Range("A" & i).Value <> "" ' loop through cells in Column "A"
Set xlApp = CreateObject("Excel.Application") ' open a new Excel instance per file
xlApp.Workbooks.Open (Hidws.Range("A" & i).Value)
i = i + 1
Set xlApp = Nothing
Loop
End Sub

VBA Excel program works only with breakpoint

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

VBA export certain data from Outlook to Excel running but producing nothing?

Option Explicit
Sub CopyToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\Rob\Documents\Excel\Excel.xlsx" 'the path of the workbook
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
'Process each selected record
rCount = xlSheet.UsedRange.Rows.Count
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = rCount + 1
'Check each line of text in the message body
For i = UBound(vText) To 0 Step 1
If InStr(1, vText(i), "Destination -") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("a" & rCount) = Trim(vItem(1))
End If
Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub
This code is from online where I tried making it work for myself...
I need to extract Specific Data from emails (over 5000) and produce them on an Excel document. I've never touched VBA before only C#, Javascript & C++.
The code runs, the excel sheet updates to the current Date/time but nothing is produced?
Any help please?
I also get an error "Subscript out of range" for this line:
xlSheet.Range("A" & rCount) = Trim(vItem(1))
I think you need to change the second split delimiter to match the first one. This will take care of the Subscript error
Use this:
vItem = Split(vText(i), "Destination -")

Paste multiple sheets into a single Word document

I'm trying to copy and paste each worksheet in a workbook onto a new sheet in a single Word document. Unfortunately it is only copying the contents of the first worksheet, though it does seem to be looping through all the worksheets. I thought that inserting a page break would work but it isn't. It also won't let me format it in Word. I want the contents of A1 to have a header style.
This is my code:
Sub ExceltoWord()
Dim ws As Worksheet
Dim Wkbk1 As Workbook
Set Wkbk1 = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
For Each ws In Wkbk1.Worksheets
Wkbk1.ActiveSheet.Range("A1:A2").Copy
Dim wdapp As Object
Dim wddoc As Object
Dim Header As Range
'file name & folder path
Dim strdocname As String
On Error Resume Next
'error number 429
Set wdapp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'create new instance of word application
Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
'define paths to file
strdocname = "P:\ImportedDescriptions.doc"
If Dir(strdocname) = "" Then
MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "P:\ImportedDescriptions.doc", vbExclamation, "The document does not exist "
Exit Sub
End If
wdapp.Activate
Set wddoc = wdapp.Documents(strdocname)
If wddoc Is Nothing Then Set wddoc = wdapp.Documents.Open(strdocname)
Set Header = Range("A1")
'must activate to be able to paste
wddoc.Activate
wddoc.Range.Paste
Selection.WholeStory
Header.Style = ActiveDocument.Styles("Heading 2")
Selection.InsertBreak Type:=wdPageBreak
Next ws
wddoc.Save
'wdapp.Quit
Set wddoc = Nothing
Set wdapp = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You are only copying from the active worksheet, which happens to be the first sheet in your case. Instead of:
For Each ws In ActiveWorkbook.Worksheets
ActiveWorkbook.ActiveSheet.Range("A1:A2").Copy
use:
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A1:A2").Copy
This will copy each range in turn.
I think it is losing track of which workbook you started with when you activate Word. Save your workbook to a Workbook variable (i.e. Dim Wkbk1 As Workbook, Set Wkbk1 = ActiveWorkbook) then replace every instance of ActiveWorkbook in your code after that with Wkbk1 (in your For Each loop and every time you want to reference it inside the loop as well).