extracting the file and invoice from SAP - vba

I have below code.
In first loop the excel file is extracted from the SAP - loop with variable a.
In the second loop (loop with variable k) the invoice is extracted from SAP (takes the order number from earlier extracted excel file).
The number of the order is taken from the excel file and paste to order in SAP.
Sometimes it happens, that order is either not taken from excel or not paste in SAP and the field for the order is empty.
This situation try to generates all the orders for the Controlling Area, which is very time-consuming (in fact it lasts hours).
I tried to add this line of code before the paste to the order, but of no result
Application.Wait Now + TimeValue("0:00:05")
Have you met this in your coding and could help with this?
extracting the excel file from SAP
Sub invoice_extr()
'##########################
'zapisuje pliki xlsx ordery
'##########################
Application.ScreenUpdating = False
SheetSrc = "Input data"
On Error Resume Next
If Not IsObject(SAPApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
If Err.Number <> 0 Then Exit Sub
Set SAPApplication = SapGuiAuto.GetScriptingEngine
If Err.Number <> 0 Then Exit Sub
End If
If Not IsObject(Connection) Then
Set Connection = SAPApplication.Children(0)
If Err.Number <> 0 Then
MsgBox ("Please, open SAP!")
Exit Sub
Else
End If
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01") / 1.5)
Dim a As Double
Dim last_row As Double
last_row = Cells(Rows.Count, 1).End(xlUp).Row
Range("b2:c" & last_row).Select
Selection.ClearContents
Dim path As String
path = Cells(2, 6)
For a = 2 To last_row
'###########################################################
'####SPRAWDZA CZY JEST JUZ PLIK XLSX O TAKIEJ NAZWIE########
'###########################################################
Dim objFSO_november1 As Object
Dim objFolder_november1 As Object
Dim objFile_november1 As Object
Dim objFile1_november1 As Object
Dim aa_november1 As Integer
Dim bb_november1 As Integer
Set objFSO_november1 = CreateObject("Scripting.FileSystemObject")
Set objFolder_november1 = objFSO_november1.GetFolder(path)
bb_november1 = 0
For Each objFile1_november1 In objFolder_november1.Files
bb_november1 = bb_november1 + 1
Next objFile1_november1
Dim myArray_november1() As Variant
ReDim Preserve myArray_november1(bb_november1, 1)
aa_november1 = 0
For Each objFile_november1 In objFolder_november1.Files
myArray_november1(aa_november1, 1) = objFile_november1.name
aa_november1 = aa_november1 + 1
Next objFile_november1
Dim aa As Double
Dim zz As Double
zz = 0
For aa = 0 To aa_november1 - 1
Dim how_many As Double
how_many = Len(Cells(a, 1))
'MsgBox (Cells(a, 1))
'MsgBox (Left(myArray_november1(aa, 1), how_many))
'MsgBox (aa)
If (Cells(a, 1) * 1) = (Left(myArray_november1(aa, 1), how_many) * 1) Then
Cells(a, 2) = "Done"
zz = zz + 1
'MsgBox (zz)
End If
If zz <> 0 Then
GoTo line1
End If
Next aa
Erase myArray_november1
If zz <> 0 Then
GoTo line1
End If
session.findById("wnd[0]").maximize
session.findById("wnd[0]/tbar[0]/okcd").Text = "/Ns_alr_87013019"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/txt$6-KOKRS").Text = Cells(a, 4)
Workbooks("Saving_invoice.xlsm").Activate
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").Text = Cells(a, 1)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").SetFocus
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").caretPosition = 6
session.findById("wnd[0]/tbar[1]/btn[8]").press
'On Error GoTo line1
On Error Resume Next
session.findById("wnd[0]/shellcont/shell/shellcont[2]/shell").hierarchyHeaderWidth = 453
session.findById("wnd[0]/usr/lbl[62,8]").SetFocus
session.findById("wnd[0]/usr/lbl[62,8]").caretPosition = 9
session.findById("wnd[0]").sendVKey 2
session.findById("wnd[1]/usr/lbl[1,2]").SetFocus
session.findById("wnd[1]/usr/lbl[1,2]").caretPosition = 4
session.findById("wnd[1]").sendVKey 2
'################################################################
'#############WYBIERA LAYOUT /MACRO##############################
'################################################################
session.findById("wnd[0]/tbar[1]/btn[33]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").currentCellRow = -1
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectColumn "VARIANT"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").contextMenu
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "/MACRO"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 6
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").clickCurrentCell
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").currentCellColumn = "BELNR"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = "0"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").contextMenu
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectContextMenuItem "&XXL"
session.findById("wnd[1]/usr/cmbG_LISTBOX").SetFocus
session.findById("wnd[1]/usr/cmbG_LISTBOX").Key = "31"
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ctxtDY_PATH").Text = path
Dim name As String
name = Cells(a, 1) & ".xlsx"
session.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = name
session.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 10
session.findById("wnd[1]/tbar[0]/btn[0]").press
'line1:
Application.Wait Now + TimeValue("0:00:05")
If Not Dir(path & name, vbDirectory) = vbNullString Then
Dim wB1 As Workbook
Dim ws1 As Worksheet
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
Set wB1 = Workbooks.Open(path & name)
Set ws1 = wB.Sheets(1)
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name).Activate
Workbooks(name).Close
Cells(a, 2) = "Done"
Else
Cells(a, 2) = "Please, check the order!"
End If
'Dim wB1 As Workbook
'Dim ws1 As Worksheet
'
' With Application
' .DisplayAlerts = False
' .EnableEvents = False
' .ScreenUpdating = False
' End With
'
' Set wB1 = Workbooks.Open(path & name)
' Set ws1 = wB.Sheets(1)
'
' Application.Wait Now + TimeValue("0:00:05")
'Workbooks(name).Activate
'
'Workbooks(name).Close
'
'Cells(a, 2) = "Checked"
line1:
Erase myArray_november1
Next a
Call invoice_extr_2
End Sub
extracting the invoice from SAP
Application.ScreenUpdating = False
SheetSrc = "Input data"
On Error Resume Next
If Not IsObject(SAPApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
If Err.Number <> 0 Then Exit Sub
Set SAPApplication = SapGuiAuto.GetScriptingEngine
If Err.Number <> 0 Then Exit Sub
End If
If Not IsObject(Connection) Then
Set Connection = SAPApplication.Children(0)
If Err.Number <> 0 Then
MsgBox ("Please, open SAP!")
Exit Sub
Else
End If
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01") / 1.5)
'####################################
'otwiera ordery i zapisuje faktury
'####################################
Workbooks("Saving_invoice.xlsm").Activate
Dim path As String
path = Cells(2, 6).Value
Dim last_row As Double
last_row = Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Double
For i = 2 To last_row
Dim name2 As String
name2 = Cells(i, 1) & ".xlsx"
Dim wB2 As Workbook
Dim ws2 As Worksheet
If Not Dir(path & name2, vbDirectory) = vbNullString Then
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
Set wB2 = Workbooks.Open(path & name2)
'Set ws2 = wB.Sheets(1)
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name2).Activate
Else
GoTo line999999999
End If
Dim last_column As Integer
last_column = Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox (last_column)
Dim nr_kolumny As Long
nr_kolumny = Cells.Find(What:="Ref Document Number", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
If Cells(1, last_column) = "action" Then
Dim ostatnia_kolumna As Integer
ostatnia_kolumna = Cells.Find(What:="action", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
Else
ostatnia_kolumna = last_column + 1
End If
If Cells(1, last_column) = "action" Then
GoTo line2
Else
Cells(1, last_column + 1).Select
ActiveCell.FormulaR1C1 = "action"
End If
line2:
Dim k As Double
Dim last_row_document
last_row_document = Cells(Rows.Count, nr_kolumny).End(xlUp).Row - 2
For k = 2 To last_row_document
If Cells(k, ostatnia_kolumna) <> "Checked" Then
Workbooks("Saving_invoice").Activate
session.findById("wnd[0]").maximize
session.findById("wnd[0]/tbar[0]/okcd").Text = "/Ns_alr_87013019"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/txt$6-KOKRS").Text = Cells(i, 4)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").Text = Cells(i, 1)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").SetFocus
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").caretPosition = 6
session.findById("wnd[0]/tbar[1]/btn[8]").press
On Error Resume Next
session.findById("wnd[0]/shellcont/shell/shellcont[2]/shell").hierarchyHeaderWidth = 453
session.findById("wnd[0]/usr/lbl[62,8]").SetFocus
session.findById("wnd[0]/usr/lbl[62,8]").caretPosition = 9
session.findById("wnd[0]").sendVKey 2
session.findById("wnd[1]/usr/lbl[1,2]").SetFocus
session.findById("wnd[1]/usr/lbl[1,2]").caretPosition = 4
session.findById("wnd[1]").sendVKey 2
'#####################################################
'##############WYBIERA LAYOUT /MACRO##################
'#####################################################
session.findById("wnd[0]/tbar[1]/btn[33]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").currentCellRow = -1
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectColumn "VARIANT"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").contextMenu
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "/MACRO"
session.findById("wnd[2]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 6
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/ssubD0500_SUBSCREEN:SAPLSLVC_DIALOG:0501/cntlG51_CONTAINER/shellcont/shell").clickCurrentCell
'######################################################
'############TUTAJ FILTROWANIE PO DOKUMENCIE###########
'######################################################
Workbooks(name2).Activate
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").setCurrentCell -1, "REFBN"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectColumn "REFBN"
session.findById("wnd[0]/tbar[1]/btn[29]").press
session.findById("wnd[1]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = Cells(k, nr_kolumny)
session.findById("wnd[1]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 8
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").currentCellColumn = "REFBN"
'session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = "0"
'session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").doubleClickCurrentCell
'###########################################################
'####SPRAWDZA CZY JEST JUZ PLIK O TAKIEJ NAZWIE#############
'###########################################################
Dim objFSO_november As Object
Dim objFolder_november As Object
Dim objFile_november As Object
Dim objFile1_november As Object
Dim aa_november As Integer
Dim bb_november As Integer
Set objFSO_november = CreateObject("Scripting.FileSystemObject")
Set objFolder_november = objFSO_november.GetFolder(path)
bb_november = 0
For Each objFile1_november In objFolder_november.Files
bb_november = bb_november + 1
Next objFile1_november
Dim myArray_november() As Variant
ReDim Preserve myArray_november(bb_november, 1)
aa_november = 0
For Each objFile_november In objFolder_november.Files
myArray_november(aa_november, 1) = objFile_november.name
aa_november = aa_november + 1
Next objFile_november
Dim z As Double
Dim how_digits As Double
how_digits = Len(Cells(k, nr_kolumny))
Dim s As Double
s = 0
For z = 0 To aa_november
If Left(myArray_november(z, 1), how_digits) = Cells(k, nr_kolumny) Then
s = s + 1
End If
Next z
Erase myArray_november
Dim h As Double
Dim o As Double
o = 0
For h = 2 To k
If Cells(h, nr_kolumny) = Cells(k, nr_kolumny) Then
o = o + 1
End If
Next h
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = o - 1 'tutaj nr linii po filtrowaniu
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").doubleClickCurrentCell
session.findById("wnd[0]/titl/shellcont/shell").pressContextButton "%GOS_TOOLBOX"
session.findById("wnd[0]/titl/shellcont/shell").selectContextMenuItem "%GOS_VIEW_ATTA"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").pressToolbarContextButton "&MB_FILTER"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/cntlCONTAINER1_FILT/shellcont/shell").currentCellRow = 2
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/cntlCONTAINER1_FILT/shellcont/shell").selectedRows = "2"
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/btnAPP_WL_SING").press
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/btn600_BUTTON").press
session.findById("wnd[3]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "Invoice"
session.findById("wnd[3]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 7
session.findById("wnd[3]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").currentCellColumn = "BITM_DESCR"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").pressToolbarButton "%ATTA_EXPORT"
session.findById("wnd[2]/usr/ctxtDY_PATH").Text = path
If s = 0 Then
session.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = Cells(k, nr_kolumny).Value & ".PDF"
Else
session.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = Cells(k, nr_kolumny).Value & "-" & s + 1 & ".PDF"
End If
session.findById("wnd[2]/usr/ctxtDY_FILENAME").caretPosition = 5
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/tbar[0]/btn[12]").press
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name2).Activate
Cells(k, ostatnia_kolumna) = "Checked"
Workbooks(name2).Save
End If
Next k
Workbooks("Saving_invoice").Activate
Cells(i, 3) = "Checked"
Workbooks("Saving_invoice.xlsm").Save
Workbooks(name2).Save
Workbooks(name2).Close
line999999999:
Next i
Workbooks("Saving_invoice.xlsm").Activate
If Cells(1, 11) = "action" Then
Columns("K:K").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
End If
Cells(1, 1).Activate
Workbooks("Saving_invoice.xlsm").Save
MsgBox ("Done")
End Sub

Well Application.Wait "The time at which you want the macro to resume, in Microsoft Excel date format." So it only pauses your VBA code but not "lets wait till some lines finishes work and we will continue" not sure how to write correctly :D bad in English. But hope you understood.
I suggest you to use Immediate window, and check everything is in place(values) with Debug.Print "My value: " & variable, also VBA is tricky and trying to make people less code while it automatically converts string, int and other stuff which is not declared or misspelled. So make on top "Option Explicit", then declare everything what is not declared.
And delete "On Error Resume Next", cause you cant see first error.

Related

Problem with myArray in the for...next loop

Below macro doesn't work correctly in myArray_november part.
This macro extracts invoice to the folder.
But some documents can be doubled, so I need to check if document already was extracted to the folder, and if it was, how many times (left 9 digits of the file name) - "s" variable in the macro.
Then I use "s" variable to define the row in the SAP report.
However the results for "s" variable are "strange".
I think this is related with myArray_november in the loop for...next or in the scope for this loop.
Could you help, please?
code
Sub salr87013019()
Application.ScreenUpdating = False
SheetSrc = "Input data"
On Error Resume Next
If Not IsObject(SAPApplication) Then
Set SapGuiAuto = GetObject("SAPGUI")
If Err.Number <> 0 Then Exit Sub
Set SAPApplication = SapGuiAuto.GetScriptingEngine
If Err.Number <> 0 Then Exit Sub
End If
If Not IsObject(Connection) Then
Set Connection = SAPApplication.Children(0)
If Err.Number <> 0 Then
MsgBox ("Please, open SAP!")
Exit Sub
Else
End If
End If
If Not IsObject(session) Then
Set session = Connection.Children(0)
End If
On Error GoTo 0
Application.Wait (Now + TimeValue("0:00:01") / 1.5)
Dim i As Double
Dim last_row As Double
last_row = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To last_row
session.findById("wnd[0]").maximize
session.findById("wnd[0]/tbar[0]/okcd").Text = "/Ns_alr_87013019"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/txt$6-KOKRS").Text = "EU01"
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").Text = Cells(i, 1)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").SetFocus
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").caretPosition = 6
session.findById("wnd[0]/tbar[1]/btn[8]").press
'On Error GoTo line1
On Error Resume Next
session.findById("wnd[0]/shellcont/shell/shellcont[2]/shell").hierarchyHeaderWidth = 453
session.findById("wnd[0]/usr/lbl[62,8]").SetFocus
session.findById("wnd[0]/usr/lbl[62,8]").caretPosition = 9
session.findById("wnd[0]").sendVKey 2
session.findById("wnd[1]/usr/lbl[1,2]").SetFocus
session.findById("wnd[1]/usr/lbl[1,2]").caretPosition = 4
session.findById("wnd[1]").sendVKey 2
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").currentCellColumn = "BELNR"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = "0"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").contextMenu
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectContextMenuItem "&XXL"
session.findById("wnd[1]/usr/cmbG_LISTBOX").SetFocus
session.findById("wnd[1]/usr/cmbG_LISTBOX").Key = "31"
session.findById("wnd[1]/tbar[0]/btn[0]").press
Dim path As String
path = Cells(2, 6)
Dim name As String
name = Cells(i, 1).Value & ".XLSX"
session.findById("wnd[1]/usr/ctxtDY_PATH").Text = path
session.findById("wnd[1]/usr/ctxtDY_FILENAME").Text = name
session.findById("wnd[1]/usr/ctxtDY_FILENAME").caretPosition = 10
session.findById("wnd[1]/tbar[0]/btn[0]").press
'line1:
Application.Wait Now + TimeValue("0:00:05")
Dim wB As Workbook
Dim ws As Worksheet
With Application
.DisplayAlerts = False
.EnableEvents = False
.ScreenUpdating = False
End With
Set wB = Workbooks.Open(path & name)
Set ws = wB.Sheets(1)
Application.Wait Now + TimeValue("0:00:05")
Workbooks(name).Activate
'Columns("K:K").Select
' Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Range("K1").Select
' ActiveCell.FormulaR1C1 = "action"
Dim k As Double
Dim last_row_document
last_row_document = Cells(Rows.Count, 10).End(xlUp).Row - 2
For k = 2 To last_row_document
session.findById("wnd[0]").maximize
session.findById("wnd[0]/tbar[0]/okcd").Text = "/Ns_alr_87013019"
session.findById("wnd[0]").sendVKey 0
session.findById("wnd[0]/usr/txt$6-KOKRS").Text = "EU01"
Workbooks("Saving_invoice").Activate
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").Text = Cells(i, 1)
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").SetFocus
session.findById("wnd[0]/usr/ctxt_6ORDGRP-LOW").caretPosition = 6
session.findById("wnd[0]/tbar[1]/btn[8]").press
On Error Resume Next
session.findById("wnd[0]/shellcont/shell/shellcont[2]/shell").hierarchyHeaderWidth = 453
session.findById("wnd[0]/usr/lbl[62,8]").SetFocus
session.findById("wnd[0]/usr/lbl[62,8]").caretPosition = 9
session.findById("wnd[0]").sendVKey 2
session.findById("wnd[1]/usr/lbl[1,2]").SetFocus
session.findById("wnd[1]/usr/lbl[1,2]").caretPosition = 4
session.findById("wnd[1]").sendVKey 2
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").setCurrentCell -1, "BELNR"
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectColumn "BELNR"
session.findById("wnd[0]/tbar[1]/btn[29]").press
Workbooks(name).Activate
session.findById("wnd[1]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = Cells(k, 10)
session.findById("wnd[1]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 9
session.findById("wnd[1]/tbar[0]/btn[0]").press
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").currentCellColumn = "BELNR"
'###########################################################
'####SPRAWDZA CZY JEST JUZ PLIK O TAKIEJ NAZWIE#############
'###########################################################
Dim objFSO_november As Object
Dim objFolder_november As Object
Dim objFile_november As Object
Dim objFile1_november As Object
Dim aa_november As Integer
Dim bb_november As Integer
Set objFSO_november = CreateObject("Scripting.FileSystemObject")
Set objFolder_november = objFSO_november.GetFolder("C:\Users\plkake\Desktop\invoice\")
bb_november = 0
For Each objFile1_november In objFolder_november.Files
bb_november = bb_november + 1
Next objFile1_november
Dim myArray_november() As Variant
ReDim Preserve myArray_november(bb_november, 1)
aa_november = 0
For Each objFile_november In objFolder_november.Files
myArray_november(aa_november, 1) = objFile_november.name
aa_november = aa_november + 1
Next objFile_november
Dim z As Double
Dim how_digits As Double
how_digits = Len(Cells(k, 10))
Dim s As Double
s = 0
For z = 0 To aa_november - 1
If Left(myArray_november(z, 1), how_digits) = Cells(k, 10) Then
s = s + 1
End If
Next z
'MsgBox (s)
'MsgBox (myArray_november(6, 1))
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").selectedRows = s 'tutaj nr linii po filtrowaniu
session.findById("wnd[0]/usr/cntlGRID1/shellcont/shell/shellcont[1]/shell").doubleClickCurrentCell
session.findById("wnd[0]/titl/shellcont/shell").pressContextButton "%GOS_TOOLBOX"
session.findById("wnd[0]/titl/shellcont/shell").selectContextMenuItem "%GOS_VIEW_ATTA"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").pressToolbarContextButton "&MB_FILTER"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectContextMenuItem "&FILTER"
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/cntlCONTAINER1_FILT/shellcont/shell").currentCellRow = 2
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/cntlCONTAINER1_FILT/shellcont/shell").selectedRows = "2"
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/btnAPP_WL_SING").press
session.findById("wnd[2]/usr/subSUB_DYN0500:SAPLSKBH:0600/btn600_BUTTON").press
session.findById("wnd[3]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").Text = "Invoice"
session.findById("wnd[3]/usr/ssub%_SUBSCREEN_FREESEL:SAPLSSEL:1105/ctxt%%DYN001-LOW").caretPosition = 7
session.findById("wnd[3]/tbar[0]/btn[0]").press
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").currentCellColumn = "BITM_DESCR"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").selectedRows = "0"
session.findById("wnd[1]/usr/cntlCONTAINER_0100/shellcont/shell").pressToolbarButton "%ATTA_EXPORT"
session.findById("wnd[2]/usr/ctxtDY_PATH").Text = path
If s = 0 Then
session.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = Cells(k, 10).Value & ".PDF"
Else
session.findById("wnd[2]/usr/ctxtDY_FILENAME").Text = Cells(k, 10).Value & "-" & s + 1 & ".PDF"
End If
session.findById("wnd[2]/usr/ctxtDY_FILENAME").caretPosition = 5
session.findById("wnd[2]/tbar[0]/btn[0]").press
session.findById("wnd[1]/tbar[0]/btn[12]").press
Application.Wait Now + TimeValue("0:00:05")
Next k
'Workbooks(name).Save
Workbooks(name).Close
Next i
End Sub
Might be helpful
' Add reference Tools.References Microsoft Scripting Runtime until code is debugged
' Then revert to create object
Dim myFSONovember As Scripting.FileSystemObject
Set myFSONovember = New Scripting.FileSystemObject
Dim myFolderNovember As Scripting.Folder
Set myFolderNovember = myFSONovember.GetFolder("C:\Users\plkake\Desktop\invoice\")
Dim myFileNovember As Variant
Dim mySdNovember As Scripting.Dictionary
Set mySdNovember = New Scripting.Dictionary
For Each myFileNovember In myFolderNovember
With mySdNovember
.Add .Count, myFileNovember.Name ' count is a dummy to satify the requirement for a key
End With
Next
Dim z As Double
Dim how_digits As Double
how_digits = Len(Cells(k, 10).Value)
Dim s As Double
s = 0
Dim myKey As Long
For Each myKey In mySdNovember
If VBA.Left$(mySdNovember.Item(myKey), how_digits) = Cells(k, 10).Value Then
s = s + 1
End If
Next z

VBA module stops seemingly without reason.

I have this VBA code which ends right after the big for loop, before "msgbox "h". The msgbox is to check if it continues. The code runs through the loop but nothing more. Can someone please help me understand why?
Sub countPT()
'Select file
Application.ScreenUpdating = False
Dim i As Integer, lastRow As Integer, tellerPoE(13) As Integer,
telleruPoE(13) As Integer, SwitchInd As Integer
Dim wb As Workbook, wb2 As Workbook
Dim krrom As String, Comment As String
For i = 1 To 13
tellerPoE(i) = 0
telleruPoE(i) = 0
Next i
Set wb = ActiveWorkbook
openFile = Application.GetOpenFilename("Excel-files,*.xls*", 1, _
"Select a file to open", , False)
Application.ScreenUpdating = False
If Len(openFile) = 0 Then
MsgBox "No file selected.", vbExclamation, "Sorry!"
End
End If
Workbooks.Open openFile
Set wb2 = ActiveWorkbook
'Read through and count -> put to array on index
lastRow = wb2.Worksheets("Rådata").Range("F" & Rows.Count).End(xlUp).Row
For i = 114 To lastRow
wb2.Activate
If CStr(wb2.Worksheets("Rådata").Cells(i, "G")) = "528" Then
krrom = CStr(wb2.Worksheets("Rådata").Cells(i, "F"))
SwitchInd = SwitchCode(krrom)
'If SwitchInd = 0 Then
'GoTo ContinueLoop
'End If
Comment = LCase(CStr(wb2.Worksheets("Rådata").Cells(i, "M")))
If (InStr(Comment, "poe") Or InStr(Comment, "kamera") Or
InStr(Comment, "cam")) Then
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
End If
tellerPoE(SwitchInd) = tellerPoE(SwitchInd) + 1
Else
If Len(wb2.Worksheets("Rådata").Cells(i, "L").Value) > 0 Then
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
telleruPoE(SwitchInd) = telleruPoE(SwitchInd) + 1
End If
'ContinueLoop
End If
Next i
'Check up to existing
'Update values
'Give message on change
MsgBox "h"
For j = 1 To 13
If tellerPoE(j) > CInt(Cells(5 + j, "E")) * 2 Or telleruPoE(j) >
CInt(Cells(5 + j, "G")) Then
Cells(6 + j, "K") = "Punkter økt"
End If
Cells(5 + j, "E") = tellerPoE(j)
Cells(5 + j, "G") = telleruPoE(j)
Next j
'Empty and close
Application.CutCopyMode = False
Set wb = ActiveWorkbook
wb2.Close
Application.ScreenUpdating = True
End Sub
Some of the code are commented out as to try to fix the problem or make it easier to find blocks
After the MsgBox, delete the loop and write the following:
MsgBox "h"
For j = 1 To 13
Cells(6 + j, "K") = "Punkter økt"
Next j
check whether it produces what you need. If it does, then it works and your condition is wrong.

Copying data from colored cells only in VBA

I have two excel sheets and a macro, which takes one and should copy only the cells with a certain background color. The rest should not be copied, because I want to keep the formulas in the original excel. My code, which gives me error is below. The error is type mismatch and it corresponds to the if statement within the loop.
Sub Take_Worksheet()
Dim strPath As String
Dim intChoice As Integer
Dim i As Integer, j As Integer
MsgBox "Select the Comments sheet"
Dim wb As Workbook
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strPath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Set wb = Workbooks.Open(strPath)
End If
For i = 1 To 100
For j = 1 To 20
If ThisWorkbook.Sheets("Comments").Cells(i, j) <> wb.Sheets("Comments").Cells(i, j) And wb.Sheets("Comments").Cells(i, j).Interior.Color = RGB(218, 238, 243) Then
ThisWorkbook.Sheets("Comments").Cells(i, j) = wb.Sheets("Comments").Cells(i, j)
End If
Application.DisplayAlerts = True
Next j
Next i
End Sub
I join #SJR: type mismatch typically happens in case of error in some cells. You can handle this this way:
If Not IsError(wb.Sheets("Comments").Cells(i, j)) Then
If ThisWorkbook.Sheets("Comments").Cells(i, j) <> wb.Sheets("Comments").Cells(i, j) And _
wb.Sheets("Comments").Cells(i, j).Interior.Color = RGB(218, 238, 243) Then
ThisWorkbook.Sheets("Comments").Cells(i, j) = wb.Sheets("Comments").Cells(i, j)
End If
End If
BTW: You should have Application.DisplayAlerts = True outside the loop.
Try this
Option Explicit
Public Sub Take_Worksheet()
Dim wsSel As Worksheet, wbPath As String, wsCom As Worksheet
Dim i As Long, j As Long, usrSelection As Long
'MsgBox "Select the Comments sheet"
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Select the Comments sheet"
usrSelection = .Show
End With
If usrSelection <> 0 Then 'continue only if user didn't cancel
Set wsCom = ThisWorkbook.Worksheets("Comments")
Set wsSel = Workbooks.Open(wbPath).Worksheets("Comments")
wbPath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)
Application.DisplayAlerts = False
For i = 1 To 100 'or wsCom.UsedRange.Rows.Count
For j = 1 To 20 'or wsCom.UsedRange.Columns.Count
If wsCom.Cells(i, j) <> wsSel.Cells(i, j) And _
wsSel.Cells(i, j).Interior.Color = RGB(218, 238, 243) Then
wsCom.Cells(i, j) = wsSel.Cells(i, j)
End If
Next j
Next i
Application.DisplayAlerts = True
End If
End Sub

VBA Error: Runtime Error: 9 - Subscript out of range when copying a worksheet from another workbook

I am generating a new workbook from a multiple workbooks, i can generate a summary of all the errors found, but when i try to copy the sheets with the error information i got the runtime error 9
These is the line failing
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
Other thing i havent add is that all the sheets on the multiple files have the same names, so i want to know if there is a way that the sheet when is copy i can add the file name and the sheet name
Sub getViolations()
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Filename = Dir(Path & "*.xls")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Dim wc As Worksheet
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = ActiveWorkbook.Sheets("Violations Summary").Range("B1")
ws.Cells(i, 2).Value = ActiveWorkbook.Sheets("Violations Summary").Range("C1")
Dim count As Integer
count = 15
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exits As Boolean
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (ActiveWorkbook.Sheets("Violations Summary").Cells(n, 2)) < 0 Then
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
End If
If IsEmpty(wc.Cells(n, 2)) Then
ws.Cells(i, n).Value = ["NA"]
End If
count = count + 1
Next n
Workbooks(Filename).Close
Filename = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
Put option explicit at top so spelling of variables is checked and that they are declared. The variable exists was mispelt and there were a number of other variables not declared. I have put some other comments in with the code.
Some of the logic i think can be simplified and i have given some examples. Also, ensure consistent use of named variable wc. If nothing else it should be easier to debug now. Compiles on my machine so give it a try.
This all works on the assumption that each workbook you open has the "Violations Summary" sheet and it is spelt as shown.
You have the filename already stored in the variable Filename so you can use (concatenate?) that with the sheetname variable.
Option Explicit 'Set this to ensure all variable declared and consistent spelling
'Consider using WorkSheets collection rather than Sheets unless you have chart sheets as well?
Sub getViolations()
Dim Path As String 'Declare you other variables
Dim FileName As String
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
FileName = Dir(Path & "*.xls")
Dim ws As Worksheet
Dim TxtRng As Range 'Declare this
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While FileName <> ""
Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
Dim wc As Worksheet 'Consider whether to place these declarations just before the loop, avoids risk others may think there will be reinitialization even though there isn't
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = wc.Range("B1") 'Use the wc variable
ws.Cells(i, 2).Value = wc.Range("C1")
Dim count As Integer
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exists As Boolean 'Corrected spelling
count = 15
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists Then 'Shortened by removing = True (evaluates in same way)
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) < 0 Then 'used wc variable
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
Else 'Simplified this as if is not empty then is empty so can use else
ws.Cells(i, n).Value = ["NA"] 'what is pupose of square brackets? These can be removed i think
End If
count = count + 1
Next n
Workbooks(FileName).Close
FileName = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
Dim Sheet As Worksheet ' declare
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
After you copy the ActiveWorkbook.Sheets(sheetName) to ThisWorkbook, ThisWorkbook becomes the ActiveWorkbook. ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1) should not throw an error but will probably cause ActiveWorkbook.Sheets("Violations Summary") to fail. For this reason, you should always fully qualify your references.
Some idealist programmers say that a subroutine should perform 1 simply task. Personally, I believe that if you have to scroll up, down, left or right to see what your code is doing it is time to refactor it. When refactoring I try to extract logical groups of tasks in a separate subroutine. This makes debugging and modifying the code far easier.
Refactored Code
Option Explicit
Sub getViolations()
Const Path As String = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Dim n As Long
Dim Filename As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Sheet1Setup ws
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
ProcessWorkbook Filename, ws.Rows(n)
Filename = Dir()
Loop
End Sub
Sub ProcessWorkbook(WBName As String, row As Range)
Dim nOffset As Long, n As Long
Dim sheetName As String
Dim WB As Workbook
Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
With WB.Sheets("Violations Summary")
row.Columns(1).Value = .Range("B1")
row.Columns(2).Value = .Range("C1")
nOffset = 12
For n = 3 To 14
If .Cells(n, 2) = "" Then
row.Columns(n).Value = ["NA"]
ElseIf (.Cells(n, 2)) = 0 Then
row.Columns(n).Font.ColorIndex = 4
row.Columns(n).Font.ColorIndex = 0
ElseIf (.Cells(n, 2)) = 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
'Range.Parent refers to the ranges worksheet. row.Parent refers to ThisWorkbook.Sheets(1)
If SheetExists(WB, sheetName) Then .Copy After:=row.Parent.Sheets(1)
row.Columns(n + nOffset) = .Cells(1, n).Value
row.Columns(n).Font.ColorIndex = 3
row.Columns(n).Value = .Cells(n, 2)
End If
Next
End With
WB.Close SaveChanges:=False
End Sub
Function SheetExists(WB As Workbook, sheetToFind As String) As Boolean
Dim ws As Worksheet
For Each ws In WB.Worksheets
If sheetToFind = ws.Name Then
SheetExists = True
Exit Function
End If
Next
End Function
Sub Sheet1Setup(ws As Worksheet)
With ws.Range("A1:N1")
.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
.Font.ColorIndex = 2
.Interior.ColorIndex = 5
.HorizontalAlignment = xlCenter
End With
End Sub
Note: row is the target Row of ThisWorkbook.Sheets(1). row.Columns(3) is a fancy way to write row.Cells(1, 3) which refers to the 3rd cell in the target row. Also note that Cells, Columns, and Rows are all relative to the range they belong to. e.g. Range("C1").Columns(2) refers to D1, Range("C1").Rows(2).Columns(2) refers to D2, Range("C1").Cells(2,2) also refers to D2.

Opening another workbook on a save event (VBA)

So, I have the code below in my "Thisworkbook" Module. I need it to run whenever the user saves the workbook. The code opens another workbook and transfers data into the new workbook.
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'Exit Sub
On Error Resume Next
Dim Mas_loc As String
Mas_loc = "C:\Users\J03800\Documents\All Folders\Berry\MasterBerry.xlsx"
Dim n As Integer
Dim m As Integer
Dim x As Integer
Dim y As Integer
Dim PartNumber As String
Dim CageCode As String
Dim PartCage As String
Dim MI As Integer
Dim ChildWB As Workbook
Dim MasterWB As Workbook
Dim IsMatch As Boolean
Dim ChiMain As Worksheet
Dim MasMain As Worksheet
Set ChildWB = ActiveWorkbook
Set MasterWB = Workbooks.Open(Mas_loc)
Set ChiMain = ChildWB.Sheets("Main")
Set MasMain = MasterWB.Sheets("Main")
n = Application.CountA(ChiMain.Range("B:B")) + 1
m = Application.CountA(MasMain.Range("B:B")) + 1
ChildWB.Activate
For x = 3 To n
PartNumber = ChiMain.Cells(x, "B").Value
CageCode = ChiMain.Cells(x, "A").Value
CSMC = ChiMain.Cells(x, "J").Value
CMC = ChiMain.Cells(x, "L").Value
MassObj = ChiMain.Cells(x, "E").Value
ComObj = ChiMain.Cells(x, "H").Value
If Len(PartNumber) > 0 Then
If Len(CageCode) > 1 Then
PartNumber = "-" & Replace(Replace(PartNumber, CageCode & "-", ""), "-" & CageCode, "")
PartCage = "Cage-" & CageCode & "-" & PartNumber
Else
PartCage = "NoCage-" & PartNumber
End If
Else
PartCage = ""
End If
On Error GoTo NewPart
MatchAddress = Application.WorksheetFunction.Match(PartCage, MasMain.Range("K1:K" & m + 20), 0)
contin:
On Error Resume Next
If Len(CSMC) > 0 And Len(Replace(CSMC, "?", "")) = Len(CSMC) And Len(MasMain.Cells(MatchAddress, "E").Value) = 0 Then
MasMain.Cells(MatchAddress, "E").Value = CSMC
End If
If Len(CMC) > 0 And Len(Replace(CMC, "?", "")) = Len(CMC) And Len(MasMain.Cells(MatchAddress, "H").Value) = 0 Then
MasMain.Cells(MatchAddress, "H").Value = CMC
End If
If Len(MassObj) > 0 And Len(Replace(MassObj, "?", "")) = Len(MassObj) And Len(MasMain.Cells(MatchAddress, "C").Value) = 0 Then
MasMain.Cells(MatchAddress, "C").Value = MassObj
End If
If Len(MassObj) > 0 And Len(Replace(MasMain.Cells(MatchAddress, "C").Value, ComObj, "")) = MasMain.Cells(MatchAddress, "C").Value Then
MasMain.Cells(MatchAddress, "G").Value = MasMain.Cells(MatchAddress, "G").Value & Chr(10) & ComObj
End If
Next
MasterWB.Close SaveChanges:=True
Exit Sub
NewPart:
On Error Resume Next
m = m + 1
MatchAddress = m
MasMain.Cells(MatchAddress, "A").Value = ChiMain.Cells(MatchAddress, "A").Value
MasMain.Cells(MatchAddress, "B").Value = ChiMain.Cells(MatchAddress, "B").Value
MasMain.Cells(MatchAddress, "K").Value = PartCage
GoTo contin
End Sub
The problem seems to be that is is not opening MasterWB. As, when it bugs out, MasterWB is both not open and according to the code equal to nothing. What should I change?
Your code block looks fine - assuming the path specified in Mas_loc is accurate.
What errors are you getting when it "bugs out"?
Have you stepped through the code to see what is happening?
I would comment out the On Error Resume Next statement to stop masking any runtime errors.
I made the sub not private, then it worked