I'm trying to parse through several Excel files and copy data to the currently open file. Here's my code. It fails at this line;
dstDecTbl(rowNdx, DstDecDeath).Value = srcDecData(SrcDecDeath).Value
Can I set ranges in different workbooks and reference them?
Option Explicit
Private Const ConstModuleName As String = "ProcessModule"
Public Sub BuildReport()
Dim srcBook As Workbook
Dim dstBook As Workbook
Dim fileSys As Object
Dim fileDir As Object
Dim fileObj As Object
Dim fileCnt As Integer
Dim srcDecData As Range
Dim srcCntData As Range
Dim dstDecTbl As Range
Dim dstCntTbl As Range
Dim fileNdx As Integer
Dim rowNdx As Integer
On Error GoTo Exception
Set dstBook = Application.ThisWorkbook
Set dstDecTbl = dstBook.Sheets(DstPage).Range(DstDecRange)
Set dstCntTbl = dstBook.Sheets(DstPage).Range(DstCntRange)
Set fileSys = CreateObject("Scripting.FileSystemObject")
Set fileDir = fileSys.GetFolder(DftSourceDir)
rowNdx = 1
fileNdx = 1
For Each fileObj In fileDir.Files
dstBook.Sheets(DstPage).Range(DstFileCount) = fileNdx
dstBook.Sheets(DstPage).Range(DstFileName) = fileObj.Name
Application.ScreenUpdating = False
Set srcBook = Workbooks.Open(fileObj.Path)
Set srcDecData = srcBook.Sheets(SrcPage).Range(SrcDecRange)
dstDecTbl(rowNdx, DstDecDeath).Value = srcDecData(SrcDecDeath).Value
rowNdx = rowNdx + 1
srcBook.Close SaveChanges:=False
Application.ScreenUpdating = True
fileNdx = fileNdx + 1
Next fileObj
Exit Sub
Exception:
Call ExceptionModule.LogException(ConstModuleName & "." & _
"buildReport", Err, vbCritical)
End Sub
Disregard, the error was in the constant definition.
Related
I have a code that has been running just fine, however, suddenly I am getting the following error:
I get the error in all the old files as well, even after completely shutting down excel. I also tried adding "AccessibilityCplAdmin 1.0 Type Library", which helped at first but doesn't anymore.
The error is in line "dData(dr, 1) = sheet.Name"
Does anyone know how this could be solved?
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Application.AutomationSecurity = msoAutomationSecurityLow
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xlsb*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsb*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
Call Copy_cells(wb_from, new_wb)
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:A100").ClearContents
Next
Sheets("Engine").Range("A1:B100").ClearContents
new_wb.Close SaveChanges:=False
RefreshLink_folder (sFolderPath_new)
IsSuccess = True
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.ScreenUpdating = True
End Sub
I have a macro that loops through the files in a folder in which the original excel with the macro lies. It then does a bunch of copy paste for each of the files in the folder. The macro works correctly for the first file in the folder, however, it then stops. Does anyone know why this is so (the starts when it says "Get the list of other tabs (column A)")? There are no errors, the macro just stops looping.
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & "*.xls*")
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Get the list of other tabs (column A)
Do While Len(sFileName) > 0
If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & sFileName
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & sFileName
End If
sFileName = Dir
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:B100").ClearContents
Loop
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
While it may be difficult to determine why it stops looping by observation/review...code can usually be re-organized to help narrow down where/what the problem is.
Given that it currently stops looping after processing the first file, it is clear that Dir is (for whatever reason) returning an empty string after the first file is processed. A first step to debugging the issue would be to isolate the task of getting all the filepaths. Once all the filepaths are determined, Then operate on each file of interest. This step is implemented in the code below.
If loading the filepaths separately fails, then you have a lot less code to debug. If all the filepaths load successfully and the code still fails, then the problem is within the subsequent loop.
As has been commented, it is possible that the code within the Do While loop is somehow preventing Dir from operating properly. If this is the case, then the code below might get the code to work. If the code still fails after collating the filepaths of interest, then start parsing out blocks of functionality within If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then. Good luck!
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:B100").ClearContents
Next
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
This worked for me in the end if anyone needs the full code. It takes the answer above, and just adjusts some of the variables:
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:A100").ClearContents
Next
Sheets("Engine").range("A1:A100").ClearContents
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
I am using a code that works great - the purpose is to send info from Outlook to Excel so I can filter it and automatize the work.
The problem is: the VBA code is executing for all e-mails received and I only want to execute it onto e-mails with subject starting with "EK".
I already tried using InStr function as below, but it doesn't work:
If InStr(xMailItem.Subject, "EK") = 0 Then
Exit Sub
End If
Where should I put this line of code?
Private Sub GMailItems_ItemAdd(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xNextEmptyRow As Integer
Dim linhas As Variant, i As Integer
Dim linhaInicial As Long
Dim numeroCaracteresAssunto As Integer
Dim assuntoEmail As String
Dim k As Integer
On Error Resume Next
If (Item.Class <> olMail) Then Exit Sub
Set xMailItem = Item
xExcelFile = "EXCELFILEPATH.xlsx"
If IsWorkBookOpen(xExcelFile) = True Then
Set xExcelApp = GetObject(, "Excel.Application")
Set xWb = GetObject(xExcelFile)
If Not xWb Is Nothing Then xWb.Close True
Else
Set xExcelApp = New Excel.Application
End If
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = Sheets.Add
numeroCaracteresAssunto = Len(xMailItem.Subject)
assuntoEmail = Right(xMailItem.Subject, numeroCaracteresAssunto - 16)
xWs.Name = UCase(assuntoEmail)
xNextEmptyRow = xWs.Range("B" & xWs.Rows.Count).End(xlUp).Row + 1
linhaInicial = 1
With xWs
linhas = Split(xMailItem.Body, vbNewLine)
For i = 0 To UBound(linhas)
Cells(linhaInicial + i, 1).Value = linhas(i)
linhaInicial = linhaInicial + 1
Next
For k = 1 To i
xWs.Range("B" & k).FormulaLocal = "=SEERRO(ÍNDICE($A$1:$A$999;MENOR(SE(ÉNÚM(LOCALIZAR(""PC"";$A$1:$A$999));CORRESP(LIN($A$1:$A$999);LIN($A$1:$A$999)));" & k & "));"""")"
xWs.Range("B" & k).FormulaArray = xWs.Range("B" & k).Formula
Next k
End With
End Sub
Instr is not case sensitive.
If InStr(UCase(xMailItem.Subject), UCase("EK")) = 0 Then
Either UCase or LCase.
On both parts, or you may run into an "eK" typo.
I want to export data from selected Outlook emails to a workbook. Each email's data (subject, body, etc.) should be stored in a different worksheet.
I'm trying to edit this macro because it is almost what I need—and especially the part of olFormatHTML and WordEditor—because of split.
The idea is
Select multiple emails in Outlook
Open file path
Data for each email selected will be stored in a single worksheet from file opened
The issue with the macro is in this third part
From the selected items, the macro does a loop and just takes the first email selected,
The data is stored in different workbooks; it should be stored in the same workbook that I opened.
Public Sub SplitEmail()
Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
'----------------------------------------------
Set itm = GetCurrentItem() 'A)I think the issuefrom selecting 1 item is located here
'|||||||||||||||||||||||||||||||||||||||||
sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"
If Not itm Is Nothing Then
Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If
Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text
'||||||||||||||||||||||||||||||||||||||||||||||
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile) 'B) tried to move it to the beginning and macro doesn't work
'||||||||||||||||||||||||||||||||||||||||||||||
For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i) 'B)emails in diferrent sheet but no same workbook
Next i
'------------------------------------------------------
Next x
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing
End Function
I made an update to this macro
as macro do loop in For x it open the file x times,
and then close it and open again instead of working on the first workbook opened
but the macro leaves open instances
here is the current code
Public Sub SplitEmail()
Dim rpl As Outlook.MailItem
Dim itm As Object
Dim sPath As String, sFile As String
Dim objDoc As Word.Document
Dim txt As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim i As Long
Dim x As Long
'----------------------------
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection
For x = 1 To myOlSel.Count
'----------------------------------------------
Dim objApp As Outlook.Application
Dim GetCurrentItem As Object
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.item(x)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
GetCurrentItem.UnRead = False
Set objApp = Nothing
'-----------------------------------------------
Set itm = GetCurrentItem
sPath = "C:\Users\Ray\"
sFile = sPath & "Macro.xlsm"
If Not itm Is Nothing Then
'de lo contrario, se crea un Reply del correo en formato HTML
Set rpl = itm.Reply
rpl.BodyFormat = olFormatHTML
'rpl.Display
End If
Set objDoc = rpl.GetInspector.WordEditor
txt = objDoc.Content.Text
'||||||||||||||||||||||||||||||||||||||||||||||
Set xlApp = CreateObject("Excel.application")
xlApp.Visible = True
Set wb = xlApp.Workbooks.Open(sFile)
xlApp.Windows("Macro.xlsm").Activate
'Set wb = ActiveWorkbook
'||||||||||||||||||||||||||||||||||||||||||||||
For i = LBound(Split(txt, Chr(13)), 1) To UBound(Split(txt, Chr(13)), 1)
wb.Worksheets(x).Range("A" & i + 1).Value = Split(txt, Chr(13))(i)
Next i
xlApp.Windows("Macro.xlsm").Close SaveChanges:=True
xlApp.Workbook.Close SaveChanges:=False
'------------------------------------------------------
Next x
'------------------------------------------------------
'the instances should closed but not working, instances are empty
For Each wb In xlApp
wb.Close SaveChanges:=False
Next
End Sub
done, I added xlApp.Quit after saving files and deleted the last part For Each wb In xlApp...
I am Trying to run this Code, which will copy the Source sheet Row to Destination Sheet last Row, but my this code giving error 400 while compiling,
Advance Thanks for Help
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
Workbooks.Open (sBook_s)
sSheet_t = "cstdatalist"
sSheet_s = "cstdata"
Sheets(sSheet_s).Range("A2").Copy Destination:=Sheets(sSheet_t).Range("A2")
End Sub
Have a try on following sub.
Sub CopyData()
Dim wb As Workbook
Dim sht, shtLocal As Worksheet
Dim rngPaste As Range
Dim rngLastData, wbPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wbPath = "D:\dBook.xlsx"
Set wb = Workbooks.Open(wbPath)
Set sht = wb.Sheets(1)
Set shtLocal = ThisWorkbook.Sheets("Sheet1")
Set rngPaste = sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Destination range set after last used cell of column A
rngLastData = shtLocal.Cells(Rows.Count, "A").End(xlUp).Address
shtLocal.Range("A1:" & rngLastData).Copy rngPaste
wb.Save
wb.Close
Set sht = Nothing
Set shtLocal = Nothing
Set rngPaste = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
enter code hereHere is my adjustment of your code. What I did is declared the workbooks and the worksheets separately. This way it is clear which workbook/sheet is the source and which is the destination.
Sub CopyData()
Dim sBook_t As String
Dim sBook_s As String
Dim workbook_t As Workbook
Dim sSheet_t As Worksheet
Dim sSheet_s As Worksheet
Dim sSheet_t As String
Dim sSheet_s As String
On Error GoTo Errorcatch
sBook_t = "C:\Users\Unknown\Desktop\Free\Calculators.xlsx"
set workbook_t = Workbooks.Open (sBook_t)
sBook_s = "C:\Users\Unknown\Desktop\Free\PRODUCT_35.xlsm"
set workbook_s = Workbooks.Open (sBook_s)
set sSheet_t = workbook_t.Sheets("cstdatalist")
set sSheet_s = workbook_s.Sheets("cstdata")
sSheet_s.Range("A2").Copy Destination:=sSheet_t.Range("A2")
End Sub