I have a macro which takes the body of an email, splits it into an array and places it into excel. It then uses colons to split rows into [label] and [data].
For some reason it has stopped working. I had some good help here but it has now failed in the second subroutine and I can't get my head around the error. I am sure it's something simple, possibly related to running from outlook or incorrect definition of ranges. Everything using rows, cells, range object etc gives this error.
The exact error is Runtime 1004 error. Method [cells, rows] of object Global failed
I have used a comment to mark the point where problems begin:
Private oXLApp As Object, oXLWb As Object, oXLWs As Object
Sub Thermo_to_excel()
Dim myOlApp As Object, mynamespace As Object
Dim ThermoMail As Object
Dim msgText, delimtedMessage, Delim1 As String
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set ThermoMail = Application.ActiveInspector.CurrentItem
delimtedMessage = ThermoMail.Body
'~~> Establish an EXCEL application object
On Error Resume Next
Set oXLApp = GetObject(, "Excel.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set oXLApp = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
Set oXLWb = oXLApp.Workbooks.Add
Set oXLWs = oXLWb.Sheets("Sheet1")
'Truncated [Array definition goes here]
With oXLWs
.Range(.Cells(1, 1), .Cells(lastRow, 1)).Value = _
oXLApp.WorksheetFunction.Transpose(messageArray)
End With
Call splitAtColons
ThermoMail.Close (olDiscard)
End Sub
Sub splitAtColons()
Dim Roows As Integer
'PROBLEMS start here now
Roows = Cells(oXLWs.Rows.Count & "," & oXLWs.ActiveCell.Column).End(xlUp).Row
Range("A1").Select
Range("A1:B" & Roows).Font.Name = Range("B1").Font.Name
Range("A1:B" & Roows).NumberFormat = "#"
'Application.ScreenUpdating = False
Do Until Z = Roows
If Not InStr(ActiveCell.Value, ":") = 0 Then
Cells(ActiveCell.Row, 2).Value = Trim(Mid(ActiveCell.Value, InStr(ActiveCell.Value, ":") + 1))
ActiveCell.Value = Left(ActiveCell.Value, InStr(ActiveCell.Value, ":"))
Else
Cells(ActiveCell.Row, 2).Value = Trim(ActiveCell.Value)
ActiveCell.Value = ""
End If
If ActiveCell.Value = "" And Range("B" & ActiveCell.Row).Value = "" Then
ActiveCell.EntireRow.Delete
Roows = Roows - 1
Z = Z - 1
End If
Range("A" & Z + 2).Select
Z = Z + 1
Loop
Columns("B:B").EntireColumn.AutoFit
Columns("A:A").EntireColumn.AutoFit
'Application.ScreenUpdating = True
End Sub
I believe your problem is that you are not fully defining your Range, Cells, & Columns functions. Try adding oXLWs. before each of those functions, or add a With oXLWs line and add . before each of those functions and see what happens.
If you run this in Excel, the Range, Cells, & Columns functions will work because they will refer to the active worksheet. If you run this through Outlook, it may not work if the sheet is not active.
Related
I used this macro a few days ago and all worked well but now it does not work properly. I get an execution error at the very beginning of the with statement, or i get another automation error.
I checked if my file exists and it exists, checked if it's found or not: all ok but when i create the excel object and begin with statement i get an error
ActiveDocument.Application.ScreenUpdating = False
Dim strSite As Site, intRow As Long, rg As Object, tmp As String, lastCol As Long, i As Long 'varibles pour derniere colonne du fichier excel et la ligne de la trigramme recherche
Dim xlapp As Object, xlbook As Object, currentcell As Object, nextcell As Object, src As Object
Dim found As String, filename
'creation du objet Excel
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
filename = "FichierTrigrammes.xlsx"
found = Dir(folderPath & "\" & "FichierTrigrammes.xlsx")
MsgBox found
If found <> vbNullString Then
' to be changed to the real File Name, if not it will not work
Set xlbook = xlapp.workbooks.Open(filename:=folderPath & filename): xlapp.Visible = False 'does not open the file, read only => faster to get the info
' searching for the Trigramm
With xlbook.sheets(1)
intRow = xlbook.sheets(1).Cells.Find(what:=strTrigram).Row
'getting the address -> to get the row therafter
'find the last non blank cell in specific row
Set currentcell = xlbook.sheets(1).Range("a" & intRow)
Do While Not IsEmpty(currentcell)
Set nextcell = currentcell.Offset(0, 1)
If nextcell.Value = currentcell.Value Then
currentcell.EntireRow.Delete
End If
Set currentcell = nextcell
Loop
lastCol = .Range(currentcell.Address).Column
For i = 1 To lastCol
Select Case .Cells(1, i).Value
Case "Type Site"
strSite.type = .Cells(intRow, i).Value
Case "Nom Site"
strSite.nomSite = .Cells(intRow, i).Value
End Select
Next i
End With
'Set xlapp = Nothing: Set xlbook = Nothing ' pour ne pas sauvegarder le document
End If
ActiveDocument.Application.ScreenUpdating = True
getSiteInfo = strSite
End Function
First issue
If you use the Range.Find method it might be that nothing is found so you will always need to test for that case.
You need always to specify the LookAt parameter for Find as xlWhole or xlPart otherwise VBA will use whatever the user or VBA used before (there is no default). If you don't specify it you never know what you get.
So something like this:
Dim FoundAt As Range
'…
FoundAt = xlbook.sheets(1).Cells.Find(What:=strTrigram, LookAt:=xlWhole)
If Not FoundAt Is Nothing Then '
intRow = FoundAt.Row
'All your other code
Else
MsgBox "'" & strTrigram & "' was not found."
End If
If you use Late Binding in Word then define the following constants:
Const xlWhole As Long = 1
Const xlPart As Long = 2
to make them available in Word.
Second issue
Note that with the following code both Set xlapp might fail and both errors will be hidden because of On Error Resume Next.
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If err Then
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Change it to
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
On Error GoTo 0
If xlapp Is Nothing Then
Set xlapp = CreateObject("Excel.Application")
End If
Third issue
You test if folderPath & "\" & "FichierTrigrammes.xlsx" exists but you open something different folderPath & filename.
Change it to
filename = "FichierTrigrammes.xlsx"
found = Dir(folderPath & Application.PathSeparator & filename)
and use that to open the file
Set xlbook = xlapp.workbooks.Open(filename:=folderPath & Application.PathSeparator & filename)
I get this error:
subscript out of range.
I do not have the debug option, only OK and HELP.
One time on 20 the macro works. The rest of time I'm getting this error.
The code makes you choose the path you want to search and next the text you want to find in the workbook in the path chosen. It searches in sub folders too. After that it sends back the file name, sheet name, which cell and what text is in the cell.
The macro runs but pops that error after searching 4 to 5 different files.
Dim AppObject As New Class1
Public WS As Worksheet
Sub SearchWKBooksSubFolders(Optional Folderpath As Variant, Optional Str As Variant)
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim Lrow As Single
Dim Folders() As String
Dim Folder As Variant
ReDim Folders(0)
Dim wbk As Workbook
If IsMissing(Folderpath) Then
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
myfolder = .SelectedItems(1) & "\"
End With
Str = Application.InputBox(prompt:="Nom de la Personne:", Title:="Personne a chercher", Type:=2)
If Str = "" Then Exit Sub
WS.Range("A1") = "Semaine"
WS.Range("B1") = "Journée"
WS.Range("C1") = "Cellule"
WS.Range("D1") = "Nom"
Folderpath = myfolder
Value = Dir(myfolder, &H1F)
Else
If Right(Folderpath, 2) = "\\" Then
Exit Sub
End If
Value = Dir(Folderpath, &H1F)
End If
Do Until Value = ""
If Value = "." Or Value = ".." Then
Else
If GetAttr(Folderpath & Value) = 16 Then
Folders(UBound(Folders)) = Value
ReDim Preserve Folders(UBound(Folders) + 1)
ElseIf Right(Value, 3) = "xls" Or Right(Value, 4) = "xlsx" Or Right(Value, 4) = "xlsm" Then
On Error Resume Next
Workbooks.Open Filename:=Folderpath & Value, Password:="zzzzzzzzzzzz"
If Err.Number <> 0 Then
WS.Range("A4").Offset(a, 0).Value = Value
WS.Range("B4").Offset(a, 0).Value = "Password protected"
a = a + 1
On Error GoTo 0
Else
For Each sht In ActiveWorkbook.Worksheets
'Expand all groups in sheet
sht.Outline.ShowLevels RowLevels:=8, ColumnLevels:=8
Set c = sht.Cells.Find(Str)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Lrow = WS.Range("A" & Rows.Count).End(xlUp).Row
WS.Range("A1").Offset(Lrow, 0).Value = Value
WS.Range("B1").Offset(Lrow, 0).Value = sht.Name
WS.Range("C1").Offset(Lrow, 0).Value = c.Address
WS.Range("D1").Offset(Lrow, 0).Value = c.Value
Set c = sht.Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Next sht
End If
Workbooks(Value).Close False
On Error GoTo 0
End If
End If
Value = Dir
Loop
For Each Folder In Folders
SearchWKBooksSubFolders (Folderpath & Folder & "\")
Next Folder
Cells.EntireColumn.AutoFit
End Sub
you can debug on your own without the debugger of the IDE.
Simply put On Error Resume Next/On Error Goto 0 very close to each other in order to restrict the statements which can raise errors. ie the second On Error Goto 0 is too far.
I can debug more effectively simply putting between statements something like that:
a = a + 1
debug.print "I am here"
b = b -5
debug.print "I am there"
c = 5 / 0
debug.print "You can't see me"
So you can find when the error is raised
I am doing IE automation using VBA (Basically I open IE and goto the specific URL from the sheet and then login using credentials from the sheet and then extract data from the webpage to excel) This has to happen for 20 websites so I added for loop and it works fine.
What I want is, in case of any error occurs with in the loop then loop has to restart.
I also tried "on error got 0, on error got -1" but it did not work.
Below is my Code - Kindly pardon me for poor coding I am new to VBA.
Sub Get_Data()
Sheets("Sheet2").Select
Range("E2").Select
Range("H6:H120").ClearContents
Dim IE As Object
Set IE = CreateObject("InternetExplorer.application")
IE.Visible = True
Dim E As Long
Dim S As Long
E = Range("A" & Rows.Count).End(xlUp).Row
JumpToHere:
For j = S To E
S = Range("H" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Select
Range("E" & S).Select
ActiveCell.Offset(1, -2).Select
Dim X As Variant
X = ActiveCell.Value
IE.navigate X
Do
If IE.ReadyState = 4 Then
IE.Visible = True
Exit Do
Else
DoEvents
End If
Loop
ActiveCell.Offset(0, 1).Select
Dim Y As Variant
Y = ActiveCell.Value
IE.document.all("username").Value = Y
ActiveCell.Offset(0, 1).Select
Dim Z As Variant
Z = ActiveCell.Value
IE.document.all("password").Value = Z
IE.document.all("merchant_login_submit_button").Click
Application.Wait (Now + TimeValue("0:00:8"))
Set ElementCol = IE.document.getElementsByTagName("span")
For Each link In ElementCol
If link.innerHTML = "Authentication Failed" Then
ActiveCell.Offset(0, 3).Value = "Authentication Failed"
GoTo JumpToHere
End If
Next
Set tags = IE.document.getElementsByTagName("input")
For Each tagx In tags
If tagx.Value = "Continue to Control Panel" Then
tagx.Click
Application.Wait (Now + TimeValue("0:00:3"))
Exit For
End If
Next
Set ElementCol = IE.document.getElementsByTagName("a")
For Each link In ElementCol
If link.innerHTML = "Reports" Then
link.Click
End If
Next
Application.Wait (Now + TimeValue("0:00:06"))
Dim checkdate As Integer
checkdate = Format(Date, "dd") - 1
IE.document.getElementById("snapshot_group_by").Value = "payment_processor"
IE.document.getElementById("snapshot_end_date_day").Value = checkdate
IE.document.all("reports_submit_button").Click
Application.Wait (Now + TimeValue("0:00:3"))
Dim ws As Worksheet
Dim rng As Range
Dim tbl As Object
Dim rw As Object
Dim cl As Object
Dim tabno As Long
Dim nextrow As Long
Dim I As Long
Set ws = Worksheets.Add
For Each tbl In IE.document.getElementsByTagName("TABLE")
tabno = tabno + 1
nextrow = nextrow + 1
Set rng = ws.Range("B" & nextrow)
rng.Offset(, -1) = "Table " & tabno
For Each rw In tbl.Rows
For Each cl In rw.Cells
rng.Value = cl.outerText
Set rng = rng.Offset(, 1)
I = I + 1
Next cl
nextrow = 0
Set rng = rng.Offset(1, -I)
I = 0
Next rw
Next tbl
ws.Cells.ClearFormats
Sheets("Sheet2").Select
ActiveCell.Offset(0, 3).Value = ActiveSheet.Previous.Range("F4")
Application.DisplayAlerts = False
ActiveSheet.Previous.Delete
Application.DisplayAlerts = True
Set ElementCol = IE.document.getElementsByTagName("a")
For Each link In ElementCol
If link.innerHTML = "Logout" Then
link.Click
End If
Next
Next j
End Sub
Sounds like your real problem is that your code isn't properly waiting. Instead of Application.Wait, use a proper waiting loop any time you invoke the IE.Navigate or any element .Click or form .Submit event.
VBA HTML not running on all computers
Otherwise, you don't have any active error-trapping in your code. Wrap your loop with On Error statements, as below.
The first one, On Error GoTo MyErrorHandler instructs the program of what to do if an error is encountered within the loop. If there's an error, the code underneath the MyErrorHandler label will execute, and resume at the NextJ label. Once the loop finishes, On Error GoTo 0 returns normal (i.e., none) error-handling. Any errors occurring outside the loop still raise an exception during runtime.
Option Explicit
Sub Get_Data()
'// Dim your variables
'// Executable code starts here
JumpToHere:
For j = S To E
On Error GoTo MyErrorHandler
' Now ANY ERROR, ANYWHERE in the loop will go to the error handler
NextJ:
Next j
'// Code below this line won't be subject to the error handler
On Error GoTo 0
'// more code if you have it
' Exit gracefully if there was no error:
Exit Sub
'// Here is the error handler:
MyErrorHandler:
Err.Clear()
Resume NextJ
End Sub
If you truly want to re-start the loop, then instead of NextJ, do Resume JumpToHere.
I simply can't find a way to hide specific columns in outlook vba. I tried everything. My current code is the following:
Sub ExportToExcel()
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim enviro As String
Dim strPath As String
Dim ns As NameSpace
Dim item As Object
Dim inbox As MAPIFolder
Dim i As Long
Dim j As Long
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\test.xlsx"
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 the message record
`On Error Resume Next
For j = 2 To 367
If xlSheet.cells(1, j).Value <> Date And xlSheet.cells(1, j).Interior.ColorIndex = 4 Then
xlSheet.Columns(j).Interior.ColorIndex = 0
End If
If xlSheet.cells(1, j).Value = Date Then
xlSheet.Columns(j).Interior.ColorIndex = 4
For i = 2 To j - 1
xlSheet.Columns(i).EntireColumn.Hidden = True
Debug.Print xlSheet.cells(1, i).Value
Next i
Exit For
End If
Next j
xlWB.Worksheets("Sheet1").Columns("A:NB").EntireColumn.AutoFit
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
End Sub
The 1st row, starting from the 2nd column of my excel sheet is populated with dates starting from 01.01.2017 and up to 31.12.2017.
I want the macro to hide all dates from before the current day.
As you can see, the debug.print in the test for hiding works as intended and prints all dates from 01.01.2017 to current date-1.
As a side note, xlSheet.Columns(i).Color = 5287936 did not work either.
By placing the On Error Resume Next from before the for in comments, I get an "Application-defined or object-defined error" error.
If I remove all the error tests, I get an "ActiveX component can't create object" error.
New finding, if I debug.print xlsheet.columns(i).hidden I get a "true" message in the immediate window. Apparently the code does exactly what it's supposed to, but it just doesn't take effect.
Try Autofit manually. You should find it unhides hidden columns.
Move Autofit so it is before the columns are hidden or be more precise about the columns to autofit.
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")
xlWB.Worksheets("Sheet1").Columns("A:NB").EntireColumn.AutoFit
' Process the message record
For j = 2 To 367
If xlSheet.Cells(1, j).Value <> Date And xlSheet.Cells(1, j).Interior.ColorIndex = 4 Then
xlSheet.Columns(j).Interior.ColorIndex = 0
End If
If xlSheet.Cells(1, j).Value <> Date And xlSheet.Cells(1, j).Interior.ColorIndex <> 0 Then
xlSheet.Columns(j).Interior.ColorIndex = 4
End If
If xlSheet.Cells(1, j).Value = Date Then
xlSheet.Columns(j).Interior.ColorIndex = 4
For i = 2 To j - 1
xlSheet.Columns(i).EntireColumn.Hidden = True
Debug.Print xlSheet.Cells(1, i).Value
Next i
Exit For
End If
Next j
I have a macro that reads the unread messages in my inbox and extracts the data from the message with a delimiter of ":" . In the loop I want to be able to load the new excel spreadsheet with the values from the message.
I am able to select the first cell and save the data but it is getting over written. each time in the loop I want the data to go to the next cell in the column that is empty instead of overwriting the same cell.
Here is my code so far...
Public Sub Application_NewMail()
Dim newbk As Workbook
Set newbk = Workbooks.Add
newbk.SaveAs "C:\Users\RickG\Desktop\test2.xlsx" 'other parameters can be set here if required
' perform operations on newbk
newbk.Close savechanges:=True
Dim ns As Outlook.NameSpace
Dim InBoxFolder As MAPIFolder
Dim InBoxItem As Object 'MailItem
Dim Contents As String, Delimiter As String
Dim Prop, Result
Dim i As Long, j As Long, k As Long
'Setup an array with all properties that can be found in the mail
Prop = Array("Name", "Email", "Phone", "Customer Type", _
"Message")
'The delimiter after the property
Delimiter = ":"
Set ns = Session.Application.GetNamespace("MAPI")
'Access the inbox folder
Set InBoxFolder = ns.GetDefaultFolder(olFolderInbox)
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ws As Worksheet
Set xlApp = New Excel.Application
With xlApp
.Visible = False
Set xlWB = .Workbooks.Open("C:\Users\RickG\Desktop\test2.xlsx", , False)
Set ws = .Worksheets("Sheet1")
End With
Dim LR As Long
For Each InBoxItem In InBoxFolder.Items
'Only process mails
If Not TypeOf InBoxItem Is MailItem Then GoTo SkipItem
'Skip wrong subjects
If InStr(1, InBoxItem.Subject, "FW: New Lead - Consumer - Help with Medical Bills", vbTextCompare) = 0 Then GoTo SkipItem
'Already processed?
If Not InBoxItem.UnRead Then GoTo SkipItem
'Mark as read
InBoxItem.UnRead = False
'Get the body
Contents = InBoxItem.Body
'Create space for the result
ReDim Result(LBound(Prop) To UBound(Prop)) As String
'Search each property
i = 1
For k = LBound(Prop) To UBound(Prop)
'Find the property (after the last position)
i = InStr(i, Contents, Prop(k), vbTextCompare)
If i = 0 Then GoTo NextProp
'Find the delimiter after the property
i = InStr(i, Contents, Delimiter)
If i = 0 Then GoTo NextProp
'Find the end of this line
j = InStr(i, Contents, vbCr)
If j = 0 Then GoTo NextProp
'Store the related part
Result(k) = Trim$(Mid$(Contents, i + Len(Delimiter), j - i - Len(Delimiter)))
'for every row, find the first blank cell and select it
'MsgBox Result(k)
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & LR).Value = Result(k)
'Update the position
i = j
NextProp:
Next
xlApp.DisplayAlerts = False
xlWB.SaveAs ("C:\Users\RickG\Desktop\test2.xlsx")
xlWB.Close
xlApp.Quit
If MsgBox(Join(Result, vbCrLf), vbOKCancel, "Auto Check In") = vbCancel Then Exit Sub
SkipItem:
Next
End Sub
You're not tracking your loop correctly. If you change
Range("A" & LR).Value = Result(k)
to
Range("A" & LR + 1).Value = Result(k)
in your
For k = LBound(Prop) To UBound(Prop)
loop, that should correct your issue.
EDIT: Sorry, findwindow. I didn't see the comment thread below the question. I just saw that the question had no answer yet.