pHAepexr

1Option Explicit
2 
3 Public Enum e_FilterType
4     e_ShowOnlyCriteriaItems = 0
5     e_HideCriteriaItems = -1
6 End Enum
7 
8 Public Enum e_ResetFilter
9    e_ClearCurrentFilters = -1
10    e_LeaveCurrentFilters = 0
11 End Enum
12 
13 Public Enum OutlookFolders
14     e_Inbox = 6
15     e_Outbox = 4
16     e_Drafts = 16
17     e_Deleted = 3
18     e_Calendar = 9
19 End Enum
20 
21 Public Enum e_ClosingAction
22     e_Save
23     e_DontSave
24     e_Delete
25 End Enum
26 
27 Public Enum e_OutlookItemTypes
28     e_Email = 43
29     e_Meeting = 26
30     e_Task = 48
31 End Enum
32 
33 Public Enum e_OutlookFlag
34     e_Complete = 1
35     e_Marked = 2
36     e_NoFlag = 0
37 End Enum
38 
39 Public Enum FieldType
40     e_General
41     e_Text
42     e_Skip
43     e_DateMDY
44     e_DateDMY
45     e_DateYMD
46 End Enum
47 
48 Public Enum e_FileNameAction
49     e_Prefix
50     e_Suffix
51     e_Replace
52 End Enum
53 
54 Public Enum e_PickerType
55     e_FilePicker
56     e_FolderPicker
57     e_OutlookPicker
58 End Enum
59 
60 Public Enum e_TableLoopTypes
61     e_Uniques
62     e_UniquesWithFilter
63     e_Visible
64     e_Formulas
65     e_Blanks
66     e_NonBlanks '//change to Visible
67 End Enum
68 
69 'Linked Applications
70 Dim app_Word As Object 'Word.Application
71 Dim app_Outlook As Object
72 
73 Dim bool_OutlookStarted As Boolean
74 
75 'DataCollection
76 Private cc_WorkbookPaths As Collection
77 Private cc_WorkbookIndexes As Collection
78 
79 'TableLoopCollection
80 'Private cc_LoopedRangesIndexes As Collection
81 'Private cc_LoopedRanges As Collection
82 Private cc_TableLoopHeaders As Collection
83 Private cc_TableLoopCursors As Collection
84 Private cc_TableLoopLevel As Collection
85 'Private cc_TableLoopLevel As Collection
86 
87 
88 'OutlookLoopCollection
89 Private cc_OutlookFolderItemIndexes As Collection
90 Private cc_OutlookFolderCursors As Collection
91 Private cc_OutlookFolders As Collection
92    
93 'Application states
94 Private lng_ApplicationEvents As Long
95 Private lng_ApplicationScreen As Long
96 Private lng_ApplicationCalculations  As Long
97 Private lng_ApplicationAlerts As Long
98 
99 Private Const adr_Calculations As String = "C1"
100 
101 Private bool_AlreadyStarted As Boolean
102 
103 Private Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long
104  
105 Public Function zATK_Version(ByRef lng_Version As Long) As Long
106     lng_Version = 3
107 End Function
108  
109  Sub xCleanCustomStyles(Optional ByVal bool_Prompt As Boolean = False, Optional ByRef wbk_Target As Workbook = Nothing)
110     Dim styT As Style
111     Dim intRet As Integer
112 
113     If wbk_Target Is Nothing Then Set wbk_Target = ThisWorkbook
114     
115 
116     For Each styT In ActiveWorkbook.Styles
117         If Not styT.BuiltIn Then
118             
119             If bool_Prompt Then
120                 intRet = MsgBox("Delete style '" & styT.Name & "'?", vbYesNo)
121             Else
122                 intRet = vbYes
123             End If
124             
125         
126             If intRet = vbYes Then
127                 Debug.Print styT.Name & " - deleted"
128                 Call styT.Delete
129             End If
130             
131         End If
132     Next styT
133 End Sub
134 
135 Private Function z_mLinkWord() As Boolean
136     Application.StatusBar = "Connecting Word"
137 
138     If app_Word Is Nothing Then
139         GoTo CREATE_APP
140     Else
141         On Error GoTo OBJECT_ZOMBIE
142         Debug.Print TypeName(app_Word.Name)
143 OBJECT_ZOMBIE:
144         If Err.Number <> 0 Then
145             Resume CREATE_APP
146         End If
147     End If
148     
149     Application.StatusBar = False
150 Exit Function
151 
152 CREATE_APP:
153         Set app_Word = CreateObject("Word.Application")
154         app_Word.Application.ScreenUpdating = False
155         app_Word.Application.DisplayAlerts = False
156         app_Word.Visible = False
157         Application.StatusBar = False
158 End Function
159  
160 Private Function z_mLinkOutlook() As Boolean
161 
162     z_mLinkOutlook = False
163 
164     Application.StatusBar = "Connecting Outlook"
165 
166     If app_Outlook Is Nothing Then
167         GoTo CREATE_APP
168     Else
169         On Error GoTo OBJECT_ZOMBIE
170         Debug.Print TypeName(app_Outlook.Name)
171 OBJECT_ZOMBIE:
172         If Err.Number <> 0 Then
173             Resume CREATE_APP
174         End If
175     End If
176     
177     z_mLinkOutlook = True
178     Application.StatusBar = False
179 
180 Exit Function
181 CREATE_APP:
182     If Err.Number <> 0 Then
183         Resume CREATE_APP
184     End If
185     
186     On Error GoTo CREATE_APP2:
187     Set app_Outlook = GetObject(, "Outlook.Application")
188     bool_OutlookStarted = False
189     
190     z_mLinkOutlook = True
191     Application.StatusBar = False
192 
193 Exit Function
194 CREATE_APP2:
195     If Err.Number <> 0 Then
196         Resume CREATE_APP2
197     End If
198 
199     On Error GoTo FAIL:
200     Set app_Outlook = CreateObject("Outlook.Application")
201     bool_OutlookStarted = True
202     
203     z_mLinkOutlook = True
204     Application.StatusBar = False
205 
206 Exit Function
207 FAIL:
208     z_mLinkOutlook = False
209     Application.StatusBar = False
210 End Function
211  
212 Function z_mChDirNet(ByVal str_FilePath As String) As Boolean
213     Dim lng_Result As Long
214     lng_Result = SetCurrentDirectoryA(str_FilePath)
215     z_mChDirNet = lng_Result <> 0
216 End Function
217 
218 Function MacroStart( _
219                     Optional bool_Calculations As Boolean = False, _
220                     Optional bool_ScreenUpdating As Boolean = False, _
221                     Optional bool_ApplicationEvents As Boolean = False, _
222                     Optional bool_DisplayAlerts As Boolean = False _
223                     )
224                     
225 'Try to load Variables to Memory
226 
227     Call Application.Run("'" & ThisWorkbook.Name & "'!LinkWorkbookTables")
228 
229     'RESET ERROR
230     If Err.Number <> 0 Then Err.Number = 0
231 
232     With Application
233     
234     'Save Application States
235         Me.Range(adr_Calculations) = .Calculation
236         lng_ApplicationEvents = .EnableEvents
237         lng_ApplicationScreen = .ScreenUpdating
238         lng_ApplicationAlerts = .DisplayAlerts
239 
240     'Setup Application for Run
241         .Calculation = bool_Calculations
242         .ScreenUpdating = bool_ScreenUpdating
243         .EnableEvents = bool_ApplicationEvents
244         .DisplayAlerts = bool_DisplayAlerts
245     
246     End With
247     
248 'Clear Loop Containers
249     Set cc_TableLoopHeaders = Nothing
250     Set cc_TableLoopCursors = Nothing
251     Set cc_WorkbookPaths = Nothing
252     Set cc_WorkbookIndexes = Nothing
253 
254     Set cc_OutlookFolderItemIndexes = Nothing
255     Set cc_OutlookFolderCursors = Nothing
256     Set cc_OutlookFolders = Nothing
257     
258     
259 End Function
260 
261 Function PickerFile(ByRef rng_FilePath As Range, Optional ByVal str_DialogText As String = "") As Boolean
262 
263     With Application.FileDialog(msoFileDialogFilePicker)
264 
265         .AllowMultiSelect = False
266         If str_DialogText <> "" Then .Title = str_DialogText
267         If .Show Then
268             If .SelectedItems(1) <> "" Then
269                 Call rng_FilePath.Hyperlinks.Add(rng_FilePath, .SelectedItems(1), , , .SelectedItems(1))
270             End If
271         End If
272 
273     End With
274 
275 End Function
276 Function PickerFolder(ByRef rng_FilePath As Range, Optional ByVal str_DialogText As String = "") As Boolean
277 
278     With Application.FileDialog(msoFileDialogFolderPicker)
279 
280         .AllowMultiSelect = False
281         If str_DialogText <> "" Then .Title = str_DialogText
282         If .Show Then
283             If .SelectedItems(1) <> "" Then
284                 Call rng_FilePath.Hyperlinks.Add(rng_FilePath, .SelectedItems(1), , , .SelectedItems(1))
285             End If
286         End If
287     End With
288 
289 End Function
290 
291 Function PickerOutlook(ByRef rng_FolderPath As Range, Optional ByVal str_DialogText As String = "") As Boolean
292 
293     If Not z_mLinkOutlook Then Exit Function
294 
295     If str_DialogText <> "" Then MsgBox str_DialogText
296     
297     Dim obj_OutlookFolder As Object
298     
299     Call z_mOutlookGetFolder(obj_OutlookFolder)
300     
301     rng_FolderPath.Value = CStr(obj_OutlookFolder.FolderPath)
302 
303 End Function
304 
305 Private Function z_mOutlookGetFolder(ByRef obj_OutlookFolder As Object, Optional ByVal FolderPath As String) As Boolean
306     
307     z_mOutlookGetFolder = False
308     
309     If Not z_mLinkOutlook Then Exit Function
310     
311     Dim SearchedFolder As Object
312     Dim FoldersArray As Variant
313     Dim i As Integer
314     
315     If FolderPath = "" Then
316         Set obj_OutlookFolder = app_Outlook.GetNamespace("MAPI").PickFolder
317       
318     Else
319         On Error GoTo GetFolder_Error
320         If Left(FolderPath, 2) = "\\" Then
321             FolderPath = Mid(FolderPath, 3)
322         End If
323         'Convert folderpath to array
324         FoldersArray = Split(FolderPath, "\")
325         
326         
327         Set SearchedFolder = app_Outlook.session.Folders.Item(FoldersArray(0))
328         
329         If Not SearchedFolder Is Nothing Then
330             For i = 1 To UBound(FoldersArray, 1)
331                 Dim SubFolders As Object
332                 Set SubFolders = SearchedFolder.Folders
333                 Set SearchedFolder = SubFolders.Item(FoldersArray(i))
334                 
335                 If SearchedFolder Is Nothing Then
336                     Set obj_OutlookFolder = Nothing
337                 End If
338             Next
339         End If
340         'Return the TestFolder
341         Set obj_OutlookFolder = SearchedFolder
342         z_mOutlookGetFolder = True
343         Exit Function
344 
345     End If
346 GetFolder_Error:
347     'Set GetFolder = Nothing
348     Exit Function
349 End Function
350 
351 
352 Function EmailMoveToFolder(ByRef obj_OlItem As Object, ByVal var_FolderMoveTo As Variant) As Boolean
353 
354     If Not z_mLinkOutlook Then Exit Function
355 
356     Dim str_FolderPath As String
357     
358 
359    ' str_FolderPath = var_FolderMoveTo
360     
361     Select Case TypeName(var_FolderMoveTo)
362         Case "String"
363             str_FolderPath = var_FolderMoveTo
364         Case "Range"
365             str_FolderPath = var_FolderMoveTo.Value
366         Case Else
367     End Select
368 
369     Dim folder As Object
370 
371     If z_mOutlookGetFolder(folder, str_FolderPath) = False Then EmailMoveToFolder = False: Exit Function
372 
373     Call obj_OlItem.Move(folder)
374 
375 
376 End Function
377 
378 Function EmailReply( _
379         ByRef OlReply As Object, _
380         ByRef obj_OlItem As Object, _
381         Optional ByVal var_Body, _
382         Optional ByVal str_Subject As String = "Skip", _
383         Optional var_To, _
384         Optional var_Cc, _
385         Optional var_Bcc _
386     ) As Boolean
387 
388     'CHECK OUTLOOK CONNNECTION
389     If Not z_mLinkOutlook Then Exit Function
390 
391     'Dim OlReply As Object
392     
393     Set OlReply = obj_OlItem.Reply
394 
395 
396     With OlReply
397     
398         On Error Resume Next
399         If Not IsMissing(var_To) Then .To = Join(z_mCovertToSimpleArray(var_To), ";")
400         If Not IsMissing(var_Cc) Then .cc = Join(z_mCovertToSimpleArray(var_Cc), ";")
401         If Not IsMissing(var_Bcc) Then .Bcc = Join(z_mCovertToSimpleArray(var_Bcc), ";")
402         If Not str_Subject = "Skip" Then .Subject = str_Subject
403         On Error GoTo 0
404         
405     'HTMLBODY PART
406         Dim str_HtmlBody As String
407         
408         .display
409         str_HtmlBody = .htmlBody
410         
411         'Split mailBody Mail Body on part before empty line and part after empty line
412         Dim str_BodyStart As String
413         Dim str_BodyEnd As String
414         Dim str_Body As String
415               
416         Dim lng_BodyStart As Long
417         Dim lng_BodyEnd As Long
418         Dim lng_BodyText As Long
419           
420         Const str_EmptyLineText$ = "<p class=MsoNormal><o:p>&nbsp;</o:p></p>" 'empty line of the body
421         Const str_BodyStartTag$ = "<body "
422         Const str_BodyEndEnd$ = "</body>"
423  
424         'DEFINE BODY START
425         lng_BodyStart = InStr(1, str_HtmlBody, str_BodyStartTag) ', lng_BodyStart + Len(lng_BodyStart))
426         lng_BodyStart = InStr(lng_BodyStart, str_HtmlBody, ">") + 1
427         
428         'DEFINE BODY END
429         lng_BodyEnd = InStr(1, str_HtmlBody, str_BodyEndEnd)
430         
431         'GET BODY STRING
432         str_Body = Mid(str_HtmlBody, lng_BodyStart, lng_BodyEnd - lng_BodyStart)
433         
434         'GET BODY START AND END STRINGS
435         str_BodyStart = Mid(str_HtmlBody, 1, lng_BodyStart - 1)
436         str_BodyEnd = Mid(str_HtmlBody, lng_BodyStart, Len(str_HtmlBody))
437 
438         'PAST CODE
439         If Not IsMissing(var_Body) Then
440             .htmlBody = str_BodyStart & "<p class=MsoNormal>" & Join(z_mCovertToSimpleArray(var_Body), "<br>") & "<br>" & "</o:p></p>" & str_BodyEnd
441         End If
442         
443         Call obj_OlItem.Recipients.ResolveAll
444         
445         .Save
446         
447     End With
448     
449     Set obj_OlItem = OlReply
450 
451     EmailReply = True
452 
453 End Function
454 
455 Function EmailFolderLoop(ByRef obj_OlItem As Object, ByVal var_FolderInput As Variant, Optional ByVal var_Criteria As Variant, Optional ByVal var_Attachments As Variant) As Boolean
456 
457     Dim lng_OlItemType As Long
458     Dim folder As Object
459     Dim folderItems As Object
460     Dim lng_ItemCursor As Long
461     Dim str_FolderPath As String
462     
463     
464     str_FolderPath = var_FolderInput
465     lng_OlItemType = e_Email
466     
467     Select Case TypeName(var_FolderInput)
468         Case "String"
469             str_FolderPath = var_FolderInput
470         Case "Range"
471             str_FolderPath = var_FolderInput.Value
472         Case Else
473     End Select
474     
475     Dim arr_Criteria
476     Dim arr_Attachements
477     
478     If Not IsMissing(var_Criteria) Then
479         arr_Criteria = z_mCovertToSimpleArray(var_Criteria)
480     End If
481     
482     If Not IsMissing(var_Attachments) Then
483         arr_Attachements = z_mCovertToSimpleArray(var_Attachments)
484     End If
485     
486     Dim cc_OutlookFolderItemIndexesTemp As Collection
487     
488     If z_mKeyExists(cc_OutlookFolders, str_FolderPath) Then
489 
490         Set folderItems = cc_OutlookFolders.Item(str_FolderPath)
491         
492         'With folder
493     
494             lng_ItemCursor = cc_OutlookFolderCursors.Item(str_FolderPath)
495             
496             Set cc_OutlookFolderItemIndexesTemp = cc_OutlookFolderItemIndexes.Item(str_FolderPath)
497 
498             If lng_ItemCursor > cc_OutlookFolderItemIndexesTemp.Count Then
499                 Set obj_OlItem = Nothing
500                 
501                 Call cc_OutlookFolderCursors.Remove(str_FolderPath) 'reset
502                 Call cc_OutlookFolderCursors.Add(1, str_FolderPath)
503                 EmailFolderLoop = False
504                 Exit Function
505             Else
506             
507                 Set obj_OlItem = folderItems(cc_OutlookFolderItemIndexesTemp.Item(lng_ItemCursor))
508             
509                 Call cc_OutlookFolderCursors.Remove(str_FolderPath)
510                 Call cc_OutlookFolderCursors.Add(lng_ItemCursor + 1, str_FolderPath)
511                 EmailFolderLoop = True
512             End If
513             
514         'End With
515     
516     Else
517     
518         If z_mOutlookGetFolder(folder, str_FolderPath) = False Then EmailFolderLoop = False: Exit Function
519 
520        
521 
522         Set folderItems = folder.items
523 
524 
525     'FOLDER FILTERING
526         'Attachment Restrict
527         If Not IsMissing(var_Attachments) Then
528             Set folderItems = folderItems.Restrict("[Attachment] > 0")
529         End If
530 
531         'Criteria Restrict
532         If Not IsMissing(var_Criteria) Then
533             Dim lng_CriteriaLoop As Long
534         
535             'Criteria restrict
536             For lng_CriteriaLoop = LBound(arr_Criteria) To UBound(arr_Criteria)
537                 Set folderItems = folderItems.Restrict(arr_Criteria(lng_CriteriaLoop))
538             Next
539         End If
540  
541     'POPULATING COLLECTION
542         'With folderItems
543         
544             Dim lng_ItemsCount As Long
545             Dim bool_FirstPicked As Boolean
546     
547             Set cc_OutlookFolderItemIndexesTemp = New Collection
548        
549             lng_ItemsCount = folderItems.Count
550             bool_FirstPicked = False
551     
552             If lng_ItemsCount > 0 Then 'on empty check
553     
554                 'Attachment Check for performace completly separated from the loop
555                 If IsMissing(var_Attachments) Then
556                     
557                     'without attachment
558                     For lng_ItemCursor = lng_ItemsCount To 1 Step -1
559                         
560                         If folderItems(lng_ItemCursor).Class = lng_OlItemType Then
561                             If bool_FirstPicked = False Then
562                                 Set obj_OlItem = folderItems(lng_ItemCursor)
563                                 bool_FirstPicked = True
564                             Else
565                                 Call cc_OutlookFolderItemIndexesTemp.Add(lng_ItemCursor)
566                             End If
567                         End If
568                 
569                     Next
570                     
571                 Else
572                     'with attachmetns
573                     For lng_ItemCursor = lng_ItemsCount To 1 Step -1
574                         
575                         If folderItems(lng_ItemCursor).Class = lng_OlItemType Then
576                             
577                             Dim bool_FilenameMatch As Boolean
578                             Dim obj_Attachment As Object
579                             Dim lng_AttachmentCursor As Long
580                             
581                             bool_FilenameMatch = False
582                             
583                             'attachment lookup
584                             For Each obj_Attachment In folderItems(lng_ItemCursor).Attachments
585                                 
586                                 'check if criteria contain criteria attachments
587                                 For lng_AttachmentCursor = LBound(arr_Attachements) To UBound(arr_Attachements)
588                                     If obj_Attachment.DisplayName Like arr_Attachements(lng_AttachmentCursor) Then
589                                         bool_FilenameMatch = True
590                                         Exit For
591                                     End If
592                                 Next
593 
594                             Next obj_Attachment
595 
596                             If bool_FilenameMatch Then
597                                 If bool_FirstPicked = False Then
598                                     Set obj_OlItem = folderItems(lng_ItemCursor)
599                                     bool_FirstPicked = True
600                                 Else
601                                     Call cc_OutlookFolderItemIndexesTemp.Add(lng_ItemCursor)
602                                 End If
603                             End If
604                         
605                         End If
606                 
607                     Next
608                 
609                 End If
610                 
611                 'Items
612                 If cc_OutlookFolders Is Nothing Then Set cc_OutlookFolders = New Collection
613                 If cc_OutlookFolderItemIndexes Is Nothing Then Set cc_OutlookFolderItemIndexes = New Collection
614                 If cc_OutlookFolderCursors Is Nothing Then Set cc_OutlookFolderCursors = New Collection
615                 
616                 Call cc_OutlookFolders.Add(folderItems, str_FolderPath)
617                 
618                 'Only one item dummy collection
619                 If cc_OutlookFolderItemIndexesTemp.Count = 0 And bool_FirstPicked = True Then
620                     Call cc_OutlookFolderItemIndexesTemp.Add(1) 'enter dummy collection
621                     Call cc_OutlookFolderItemIndexes.Add(cc_OutlookFolderItemIndexesTemp, str_FolderPath)
622                     Call cc_OutlookFolderCursors.Add(2, str_FolderPath)
623                 
624                 'more then on item found
625                 ElseIf cc_OutlookFolderItemIndexesTemp.Count > 0 Then
626                     Call cc_OutlookFolderItemIndexes.Add(cc_OutlookFolderItemIndexesTemp, str_FolderPath)
627                     Call cc_OutlookFolderCursors.Add(1, str_FolderPath)
628                 
629                 End If
630                 
631                 EmailFolderLoop = bool_FirstPicked 'return true only if at least one corresponding match
632             End If
633 
634             'End With
635 
636     End If
637 
638 End Function
639 
640 Public Sub DocumentOpen(ByRef obj_WordDoc As Object, ByVal str_FileName As String, ByVal str_DirPath As String)
641 
642     Call z_mLinkWord
643 
644     Application.StatusBar = "Openning Document ... " & str_DirPath & "\" & str_FileName
645 
646     Set obj_WordDoc = app_Word.Documents.Open(str_DirPath & "\" & str_FileName)
647 
648     Application.StatusBar = False
649 
650 End Sub
651 
652 Public Sub DocumentToPDF(ByVal obj_WordDoc As Object, ByVal str_FileName As String, ByVal str_DirPath As String)
653 
654     Call z_mLinkWord
655 
656     'save as PDF'
657     obj_WordDoc.ExportAsFixedFormat OutputFileName:= _
658         str_DirPath & str_FileName, _
659         ExportFormat:=17, OpenAfterExport:=False, OptimizeFor:= _
660         0, Range:=0, From:=1, To:=1, _
661         Item:=7, IncludeDocProps:=False, KeepIRM:=True, _
662         CreateBookmarks:=0, DocStructureTags:=True, _
663         BitmapMissingFonts:=True, UseISO19005_1:=False
664 
665 End Sub
666 
667 Public Sub DocumentSaveAs(ByVal obj_WordDoc As Object, ByVal str_FileName As String, ByVal str_DirPath As String)
668 
669     Call z_mLinkWord
670 
671     Application.StatusBar = "Openning Saving Document as ... " & str_DirPath & "\" & str_FileName
672 
673     obj_WordDoc.SaveAs str_DirPath & "\" & str_FileName
674 
675     Application.StatusBar = False
676 
677 End Sub
678 
679 Public Sub DocumentClose(ByVal obj_WordDoc As Object, ByVal bool_SaveDocument As Boolean)
680 
681     Call z_mLinkWord
682         
683     Application.StatusBar = "Closing Document ... " & obj_WordDoc.Name & IIf(bool_SaveDocument, "", " Without Saving")
684     
685     Call obj_WordDoc.Close(bool_SaveDocument)
686 
687     Application.StatusBar = False
688 
689 End Sub
690 
691 Public Function DocumentReplaceText( _
692         ByRef obj_WordDoc As Object, _
693         Optional ByRef t_SingleItems As ListObject, _
694         Optional ByRef t_Table0 As ListObject, _
695         Optional ByRef t_Table1 As ListObject, _
696         Optional ByRef t_Table2 As ListObject, _
697         Optional ByRef t_Table3 As ListObject, _
698         Optional ByRef t_Table4 As ListObject, _
699         Optional ByRef t_Table5 As ListObject, _
700         Optional ByRef t_Table6 As ListObject, _
701         Optional ByRef t_Table7 As ListObject, _
702         Optional ByRef t_Table8 As ListObject, _
703         Optional ByRef t_Table9 As ListObject _
704     )
705         
706 
707     t_SingleItems.Range.Calculate
708    
709     'FILL BODY ITEMS
710     
711     Dim rng_Cursor As Range
712     
713     With obj_WordDoc.Range.Find
714     'Document single items
715         If Not t_SingleItems Is Nothing Then
716             For Each rng_Cursor In t_SingleItems.HeaderRowRange
717                 .Execute rng_Cursor.Value, True, True, False, , , , , , rng_Cursor.Offset(1).Value, 2
718             Next
719         End If
720     End With
721 
722 
723 'IF LIST EXIST ADD LIST ITEMS
724     Dim obj_Table As Object
725     Dim lng_TableCorsor As Long
726 
727     For lng_TableCorsor = 1 To obj_WordDoc.tables.Count
728 
729         Set obj_Table = obj_WordDoc.tables(lng_TableCorsor)
730 
731         Select Case obj_Table.Title
732             Case 0:  If Not t_Table0 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table0, 0)
733             Case 1: If Not t_Table1 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table1, 1)
734             Case 2: If Not t_Table2 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table2, 2)
735             Case 3:  If Not t_Table3 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table3, 3)
736             Case 4: If Not t_Table4 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table4, 4)
737             Case 5: If Not t_Table5 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table5, 5)
738             Case 6:  If Not t_Table6 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table6, 6)
739             Case 7: If Not t_Table7 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table7, 7)
740             Case 8: If Not t_Table8 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table8, 8)
741             Case 9:  If Not t_Table9 Is Nothing Then Call DocumentTableLoad(obj_Table, t_Table9, 9)
742         End Select
743     
744     Next
745 
746 
747 End Function
748 
749 Public Function DocumentTableLoad(ByVal obj_Table As Object, ByVal t_Table As ListObject, ByVal lng_TableIndex As Long)
750     
751     Dim lng_RowsCount As Long
752     Dim lng_RowsCounter As Long
753          
754     t_Table.Range.Calculate
755          
756     t_Table.MoveLast
757     lng_RowsCount = t_Table.DataBodyRange.Rows.Count
758     t_Table.MoveFirst
759     
760     With obj_Table
761 
762             .Rows(1).Select
763             app_Word.Selection.InsertRowsBelow (lng_RowsCount - 1)
764             .Rows(1).Select
765              app_Word.Selection.Copy
766              app_Word.Selection.MoveDown Unit:=5, Count:=1 '5=wdLine
767              app_Word.Selection.MoveDown Unit:=5, Count:=(lng_RowsCount - 2), Extend:=1  '5=wdLine, 1= wdExtend
768              app_Word.Selection.Paste
769             
770             lng_RowsCounter = 1
771             Dim rng_Cursor As Range
772             Do Until lng_RowsCounter <> lng_RowsCount
773                 
774                 With .Rows(lng_RowsCounter).Range.Find
775                     For Each rng_Cursor In t_Table.HeaderRowRange
776                         .Execute "[" & rng_Cursor.Value & "]" & lng_TableIndex, True, True, False, , , , , , rng_Cursor.Offset(lng_RowsCounter - 1).Value, 2
777                     Next
778                 End With
779 
780                 t_Table.MoveNext
781                 lng_RowsCounter = lng_RowsCounter + 1
782     
783             Loop
784 
785     End With
786     
787 End Function
788 Function MacroFinish()
789 
790 'Check if in words is no anything open if yes show word
791     If Not app_Word Is Nothing Then
792         If app_Word.Documents.Count = 0 Then
793             app_Word.Application.ScreenUpdating = True
794             app_Word.Application.Quit 0 'quit without saving
795             Set app_Word = Nothing
796         Else
797             app_Word.Visible = False
798         End If
799     End If
800 
801 'Check if outlook was started then close
802     If Not app_Outlook Is Nothing And bool_OutlookStarted Then
803         app_Outlook.Quit
804     End If
805 
806 'Loading original data to Excel
807     With Application
808         .Calculation = lng_ApplicationCalculations
809         .ScreenUpdating = lng_ApplicationScreen
810         .EnableEvents = lng_ApplicationEvents
811         .DisplayAlerts = lng_ApplicationAlerts
812         .StatusBar = False
813     End With
814     
815 'Clear Loop Containers to freeup memory
816    ' Set cc_LoopedRanges = Nothing
817    ' Set cc_LoopedRangesIndexes = Nothing
818     Set cc_TableLoopHeaders = Nothing
819     Set cc_TableLoopCursors = Nothing
820     Set cc_WorkbookPaths = Nothing
821     Set cc_WorkbookIndexes = Nothing
822 
823     Set cc_OutlookFolderItemIndexes = Nothing
824     Set cc_OutlookFolderCursors = Nothing
825     Set cc_OutlookFolders = Nothing
826 
827 End Function
828 
829 Function TableClear(ByVal tbl_Object As ListObject)
830 
831     Application.StatusBar = "Clearing Table " & tbl_Object.Name
832 
833     On Error GoTo Err
834 
835     Dim rng_ClearRange As Range
836     
837 'check if there is rows to remove
838     If tbl_Object.Range.Rows.Count > 2 Then
839         
840         Set rng_ClearRange = tbl_Object.Range.Worksheet.Range(tbl_Object.Range.Offset(2).Resize(tbl_Object.Range.Rows.Count - 2).Address)
841     
842     'resize table
843         Call tbl_Object.Resize(tbl_Object.HeaderRowRange.Resize(2))
844         
845         'clear the rest
846         rng_ClearRange.Clear 'clear with formulas
847         
848     End If
849 
850 'reset autofilter
851     tbl_Object.Range.AutoFilter
852     tbl_Object.ShowAutoFilter = True
853 
854 'clear table data
855     If tbl_Object.Range.Columns.Count = 1 Then 'avoid whole table removal
856          tbl_Object.HeaderRowRange.Offset(1).ClearContents 'clear just data
857     Else
858          tbl_Object.HeaderRowRange.Offset(1).SpecialCells(xlCellTypeConstants).ClearContents 'clear just data
859     End If
860     
861     tbl_Object.Range.Calculate
862     
863 Err:
864     Application.StatusBar = False
865 
866     Debug.Print Err.Description
867 
868     Select Case Err.Number
869         Case 0
870         Case 1004: If Err.Description = "No cells were found." Then Exit Function
871     End Select
872 
873 End Function
874 
875 Function TableClearAll(ByVal tbl_Object As ListObject)
876 
877     Dim rng_TempTable As Range
878     
879 
880     On Error GoTo Err
881     Set rng_TempTable = tbl_Object.DataBodyRange
882 
883     'reset autofilter
884     Call tbl_Object.Range.AutoFilter
885     tbl_Object.ShowAutoFilter = True
886 
887     Call tbl_Object.Resize(tbl_Object.HeaderRowRange.Resize(2))
888 
889     rng_TempTable.ClearContents
890         
891 Err:
892 End Function
893 Function TableClearVisible(ByVal tbl_Object As ListObject)
894 
895     Dim rng_BodyToDelete As Range
896     'deleting
897     On Error Resume Next
898     Set rng_BodyToDelete = tbl_Object.DataBodyRange.SpecialCells(xlCellTypeVisible)
899     On Error GoTo 0
900     
901     If Not rng_BodyToDelete Is Nothing Then
902       If rng_BodyToDelete.Address = tbl_Object.DataBodyRange.Address Then
903         Call TableClear(tbl_Object)
904       Else
905         
906         rng_BodyToDelete.Delete
907       End If
908     End If
909     
910     'reset autofilter
911     tbl_Object.Range.AutoFilter
912     tbl_Object.ShowAutoFilter = True
913 
914 End Function
915 
916 Private Function z_mCovertToSimpleArray( _
917                                             ByVal arr_Criteria As Variant, _
918                                             Optional ByVal bool_ReturnDateVersion As Boolean = False) As Variant
919 
920     Dim arr_TempCriteria
921 
922     'If Entered table then change to Range
923     If TypeName(arr_Criteria) = "ListObject" Then
924         Dim rng_Temp As Range
925         
926         On Error Resume Next
927         Set rng_Temp = arr_Criteria.DataBodyRange
928         On Error GoTo 0
929         
930         If Not rng_Temp Is Nothing Then Set arr_Criteria = rng_Temp
931         
932     End If
933     
934     'New Range Item
935     Select Case TypeName(arr_Criteria)
936         Case "Range"
937         
938             'merge area check
939             If arr_Criteria.MergeCells Then
940                ' ReDim arr_TempCriteria(0)
941                 
942                 If arr_Criteria.Worksheet.Range(Split(arr_Criteria.Address, ":")(0)).Value = Empty Then
943                     arr_TempCriteria = CVar(Array(vbNullString))
944                 Else
945                     arr_TempCriteria = Array(arr_Criteria.Worksheet.Range(Split(arr_Criteria.Address, ":")(0)).Value)
946                 End If
947                 
948                 GoTo Exit_Function:
949             Else
950             
951                 arr_TempCriteria = arr_Criteria.Value
952             
953                 If arr_Criteria.Count > 1 Then
954                     arr_TempCriteria = z_mCovertToSimpleArray(arr_TempCriteria)
955                 Else
956                     arr_TempCriteria = Array(arr_TempCriteria)
957                 End If
958     
959             End If
960     
961         Case "Variant()"
962             If z_mIs2dArray(arr_Criteria) Then
963                 Dim r_Cursor As Long
964                 Dim c_Cursor As Long
965                 Dim lng_ItemCounter As Long
966                 
967                 lng_ItemCounter = 0
968                 'Dim arr_TempCriteria1D()
969                 ReDim arr_TempCriteria(0)
970                 ReDim arr_TempCriteria((UBound(arr_Criteria) * UBound(arr_Criteria, 2)) - 1)
971                 
972                 For r_Cursor = LBound(arr_Criteria) To UBound(arr_Criteria)
973                     For c_Cursor = LBound(arr_Criteria, 2) To UBound(arr_Criteria, 2)
974     
975                         arr_TempCriteria(lng_ItemCounter) = arr_Criteria(r_Cursor, c_Cursor)
976                         lng_ItemCounter = lng_ItemCounter + 1
977                     
978                     Next
979                 Next
980                 
981             Else
982                 z_mCovertToSimpleArray = arr_Criteria
983                 Exit Function
984             End If
985     
986         Case "String", "Long", "Integer"
987             arr_TempCriteria = Array(arr_Criteria)
988         Case "Date"
989             arr_TempCriteria = Array(arr_Criteria)
990         Case "Boolean"
991             arr_TempCriteria = Array(arr_Criteria)
992         Case Else
993             
994     End Select
995 
996     If bool_ReturnDateVersion Then
997     
998     Dim lng_Date As Long
999     'Criteria Range To Date
1000         For r_Cursor = LBound(arr_TempCriteria) To UBound(arr_TempCriteria)
1001             lng_Date = CLng(Fix(CCur(arr_TempCriteria(r_Cursor))))
1002             arr_TempCriteria(r_Cursor) = CStr(Month(lng_Date)) & "/" & CStr(Day(lng_Date)) & "/" & CStr(Year(lng_Date))
1003         Next
1004 
1005     End If
1006 
1007     z_mCovertToSimpleArray = arr_TempCriteria
1008 
1009 Exit_Function:
1010 End Function
1011 '
1012 'Private Function z_mCovertToSimpleArray(ByRef arr_Criteria As Variant, Optional ByVal bool_ReturnDateVersion As Boolean = False)
1013 '
1014 'Dim arr_TempCriteria()
1015 '
1016 'Select Case TypeName(arr_Criteria)
1017 '    Case "Range"
1018 '        arr_TempCriteria = arr_Criteria.Value
1019 '
1020 '        If arr_Criteria.Count > 1 Then
1021 '            Call z_mCovertToSimpleArray(arr_TempCriteria)
1022 '        Else
1023 '            arr_TempCriteria = Array(arr_TempCriteria)
1024 '        End If
1025 '
1026 '    Case "Variant()"
1027 '        If z_mIs2dArray(arr_Criteria) Then
1028 '            Dim r_Cursor As Long
1029 '            Dim c_Cursor As Long
1030 '            Dim lng_ItemCounter As Long
1031 '
1032 '            lng_ItemCounter = 0
1033 '            ReDim arr_TempCriteria(0)
1034 '            ReDim arr_TempCriteria((UBound(arr_Criteria) * UBound(arr_Criteria, 2)) - 1)
1035 '
1036 '            For r_Cursor = LBound(arr_Criteria) To UBound(arr_Criteria)
1037 '                For c_Cursor = LBound(arr_Criteria, 2) To UBound(arr_Criteria, 2)
1038 '
1039 '                    arr_TempCriteria(lng_ItemCounter) = arr_Criteria(r_Cursor, c_Cursor)
1040 '                    lng_ItemCounter = lng_ItemCounter + 1
1041 '
1042 '                Next
1043 '            Next
1044 '        Else
1045 '            Exit Function
1046 '        End If
1047 '
1048 '    Case "String", "Long", "Integer"
1049 '        arr_TempCriteria = Array(arr_Criteria)
1050 '    Case "Date"
1051 '        arr_TempCriteria = Array(arr_Criteria)
1052 '    Case "Boolean"
1053 '    Case Else
1054 '
1055 'End Select
1056 '
1057 'arr_Criteria = arr_TempCriteria
1058 '
1059 'End Function
1060 
1061 Private Sub z_mVariantValue(ByRef ChangedVariant As Variant, ByVal ChangingVariant)
1062     ChangedVariant = ChangingVariant
1063 End Sub
1064 
1065 Private Function z_mIs2dArray(ByVal var_Array) As Boolean
1066     
1067     z_mIs2dArray = False
1068     
1069     On Error GoTo Err:
1070 
1071     Dim lng_2d As Long
1072     
1073     lng_2d = UBound(var_Array, 2)
1074 
1075     z_mIs2dArray = True
1076 
1077     Exit Function
1078 
1079 Err:
1080 
1081 End Function
1082 
1083 Function TableAutofilterDate( _
1084                         ByRef tbl_Object As ListObject, _
1085                         Optional ByRef str_ColumnName As String = "", _
1086                         Optional ByRef arr_CriteriaInput As Variant, _
1087                         Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
1088                         Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
1089                         )
1090     
1091     On Error GoTo Err:
1092     
1093 'PREPARE TABLE
1094     Dim str_TableName$
1095     Dim lng_ColumnIndex&
1096     Dim i_Values&
1097     Dim lng_Date&
1098     Dim arr_Criteria()
1099     
1100     str_TableName = tbl_Object.Name
1101     
1102 'reset autofilter
1103     If str_ColumnName = "" Then
1104         tbl_Object.Range.AutoFilter
1105         tbl_Object.ShowAutoFilter = True
1106         Exit Function
1107     End If
1108     
1109 'find column index of the name of column
1110     lng_ColumnIndex = tbl_Object.Range.Rows(1).Find(str_ColumnName).Column - (tbl_Object.Range.Column - 1)
1111     
1112 'autofilter before filtering
1113     If RemoveAutoFilter Then tbl_Object.Range.AutoFilter
1114     
1115 'check if autofilter is not turned of
1116     If Not tbl_Object.ShowAutoFilter Then tbl_Object.ShowAutoFilter = True
1117     
1118 'PREPARE CRITERIA
1119 'check if filter list is not array
1120     
1121     'If TypeName(arr_Criteria) = "Range" Then arr_Criteria = RangeToArray(arr_Criteria)
1122     
1123     arr_Criteria = z_mCovertToSimpleArray(arr_CriteriaInput, True)
1124     
1125 '    For i_Values = 0 To UBound(arr_Criteria)
1126 '        lng_Date = CLng(Fix(CCur(arr_Criteria(i_Values))))
1127 '        arr_Criteria(i_Values) = CStr(Month(lng_Date) & "/" & Day(lng_Date) & "/" & Year(lng_Date))
1128 '    Next
1129     
1130 'check if there is not required negative autofilter
1131     If InvertedAutoFilter Then
1132         Dim arr_ColumnData
1133         arr_ColumnData = WorksheetFunction.Transpose(tbl_Object.Range.Worksheet.Range(str_TableName & "[" & str_ColumnName & "]"))
1134         
1135         For i_Values = 1 To UBound(arr_ColumnData)
1136             lng_Date = CLng(Fix(CCur(arr_ColumnData(i_Values))))
1137             arr_ColumnData(i_Values) = CStr(Month(lng_Date) & "/" & Day(lng_Date) & "/" & Year(lng_Date))
1138         Next
1139         
1140         Call z_mArrayFilterUnique(arr_ColumnData, arr_Criteria)
1141     End If
1142     
1143 'DateAutofilter Criteria Array
1144     Dim arr_DateCritieria
1145     Dim i&
1146     
1147 'Date Criteria
1148     ReDim arr_DateCritieria((UBound(arr_Criteria) * 2) + 1)
1149     For i = LBound(arr_Criteria) To UBound(arr_Criteria)
1150         'lng_Date = Fix(CLng(arr_Criteria(i)))
1151         arr_DateCritieria(i * 2) = 2 'criteria scope taken 0-Year,1-Month,2-Day,3-Hour,4-Minute
1152         arr_DateCritieria(i * 2 + 1) = arr_Criteria(i)
1153     Next
1154     
1155 'apply autofilter
1156     tbl_Object.Range.AutoFilter _
1157         Field:=lng_ColumnIndex, _
1158         Criteria2:=arr_DateCritieria, _
1159         Operator:=xlFilterValues
1160     Exit Function
1161     
1162 Err:
1163     Debug.Print Err.Number & " " & Err.Description
1164     Debug.Assert False
1165     Resume
1166 
1167 End Function
1168 
1169 Function TableAutofilter( _
1170                     ByVal tbl_Object As ListObject, _
1171                     Optional ByVal str_ColumnName As String = "", _
1172                     Optional ByVal arr_CriteriaInput As Variant, _
1173                     Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
1174                     Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
1175                     )
1176                     
1177     Application.StatusBar = "Filtering table: " & tbl_Object.Name & " in Column: " & str_ColumnName
1178                     
1179     
1180     Dim str_TableName$
1181     Dim lng_ColumnIndex&
1182 
1183     str_TableName = tbl_Object.Name
1184     
1185 'check do - reset autofilter
1186     If str_ColumnName = "" Then
1187         tbl_Object.Range.AutoFilter
1188         tbl_Object.ShowAutoFilter = True
1189         Exit Function
1190     End If
1191 
1192     
1193 'find column index of the name of column
1194     lng_ColumnIndex = tbl_Object.HeaderRowRange.Find(str_ColumnName).Column - (tbl_Object.Range.Column - 1)
1195     
1196 'check do - reset filter in column
1197     If str_ColumnName <> "" And IsMissing(arr_CriteriaInput) Then
1198         tbl_Object.Range.AutoFilter lng_ColumnIndex
1199         Exit Function
1200     End If
1201     
1202 'autofilter before filtering
1203     If RemoveAutoFilter Then tbl_Object.Range.AutoFilter
1204     
1205 'check if autofilter is not turned of
1206     If tbl_Object.ShowAutoFilter Then tbl_Object.ShowAutoFilter = True
1207     
1208 'recalculate column data
1209     Call z_mRangeRecalculate(tbl_Object.Range.Worksheet.Range(str_TableName & "[" & str_ColumnName & "]"))
1210     
1211 'check if filter list is not array
1212     Dim arr_Criteria
1213     arr_Criteria = z_mCovertToSimpleArray(arr_CriteriaInput)
1214     
1215 'check if there is not required negative autofilter
1216     If InvertedAutoFilter Then
1217         Dim arr_ColumnData
1218         arr_ColumnData = WorksheetFunction.Transpose(tbl_Object.Range.Worksheet.Range(str_TableName & "[" & str_ColumnName & "]"))
1219         
1220         arr_ColumnData = z_mCovertToSimpleArray(arr_ColumnData)
1221         
1222         If Not z_mArrayFilterUnique(arr_ColumnData, arr_Criteria) Then
1223             'Exit Function
1224         End If
1225     Else
1226        'convert integer and long numbers to strings
1227         Dim i&
1228         For i = LBound(arr_Criteria) To UBound(arr_Criteria)
1229             arr_Criteria(i) = CStr(arr_Criteria(i))
1230         Next
1231     End If
1232     
1233     'SPECIAL CHARACTER SETTINGS
1234     If arr_Criteria(0) = "<>" And UBound(arr_Criteria) = 0 Then
1235         tbl_Object.Range.AutoFilter _
1236             Field:=lng_ColumnIndex, _
1237             Criteria1:=arr_Criteria(0)
1238             
1239         GoTo Exit_Function
1240     End If
1241     
1242     'apply autofilter
1243     tbl_Object.Range.AutoFilter _
1244         Field:=lng_ColumnIndex, _
1245         Criteria1:=arr_Criteria, _
1246         Operator:=xlFilterValues
1247 
1248     
1249     Application.StatusBar = False
1250     
1251 Exit_Function:
1252 
1253 End Function
1254 
1255 
1256 Private Function z_mRangeRecalculate(ByRef rng_Range As Range) As Boolean
1257     
1258     z_mRangeRecalculate = False
1259     
1260     Dim rng_Formulas As Range
1261     
1262 On Error Resume Next
1263     Set rng_Formulas = rng_Range.SpecialCells(xlCellTypeFormulas)
1264 On Error GoTo 0
1265 
1266     If Not rng_Formulas Is Nothing Then
1267         rng_Formulas.Calculate
1268         z_mRangeRecalculate = True
1269     End If
1270 
1271 End Function
1272 
1273 Function RangeAutofilter( _
1274                 ByVal rng_SourceRange As Range, _
1275                 Optional ByVal lng_HeaderRow As Long = 1, _
1276                 Optional ByVal str_ColumnName As String = "", _
1277                 Optional ByVal arr_Criteria As Variant, _
1278                 Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
1279                 Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
1280                 )
1281     
1282  '   Dim str_TableName$
1283     Dim lng_ColumnIndex&
1284     Dim lng_DataRowsCount&
1285     
1286     Set rng_SourceRange = rng_SourceRange.CurrentRegion
1287     lng_DataRowsCount = rng_SourceRange.Rows.Count - lng_HeaderRow 'calculate number of rows below header row
1288     lng_HeaderRow = lng_HeaderRow - 1 'remove one row for ofset
1289 
1290 'reset autofilter
1291     If str_ColumnName = "" Then
1292         rng_SourceRange.AutoFilter
1293         rng_SourceRange.ShowAutoFilter = True
1294         Exit Function
1295     End If
1296     
1297 'find column index of the name of column
1298     lng_ColumnIndex = rng_SourceRange.Resize(1).Offset(lng_HeaderRow).Find(str_ColumnName).Column - (rng_SourceRange.Resize(1, 1).Column - 1)
1299     
1300 'autofilter before filtering
1301     If RemoveAutoFilter Then rng_SourceRange.AutoFilter
1302 
1303 'check if filter list is not array
1304     If TypeName(arr_Criteria) = "Range" Then arr_Criteria = RangeToArray(arr_Criteria)
1305     
1306 'check if there is not required negative autofilter
1307     If InvertedAutoFilter Then
1308         Dim arr_ColumnData
1309         arr_ColumnData = WorksheetFunction.Transpose(rng_SourceRange.Resize(lng_DataRowsCount, 1).Offset(lng_HeaderRow, lng_ColumnIndex))
1310         
1311         If Not z_mArrayFilterUnique(arr_ColumnData, arr_Criteria) Then
1312             'Exit Function
1313         End If
1314     Else
1315        'convert integer and long numbers to strings
1316         Dim i&
1317         For i = LBound(arr_Criteria) To UBound(arr_Criteria)
1318             arr_Criteria(i) = CStr(arr_Criteria(i))
1319         Next
1320     End If
1321     
1322 
1323     If UBound(arr_Criteria) = 0 Then
1324         rng_SourceRange.Resize(lng_DataRowsCount + 1).Offset(lng_HeaderRow).AutoFilter _
1325             Field:=lng_ColumnIndex, _
1326             Criteria1:=arr_Criteria(0)
1327     Else
1328         'apply autofilter
1329         rng_SourceRange.Resize(lng_DataRowsCount + 1).Offset(lng_HeaderRow).AutoFilter _
1330             Field:=lng_ColumnIndex, _
1331             Criteria1:=arr_Criteria, _
1332             Operator:=xlFilterValues
1333     End If
1334 
1335 End Function
1336 
1337 Function RangeAutofilterDate( _
1338                             ByVal rng_SourceRange As Range, _
1339                             Optional ByVal lng_HeaderRow& = 1, _
1340                             Optional ByVal str_ColumnName$ = "", _
1341                             Optional ByVal arr_Criteria, _
1342                             Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
1343                             Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
1344                             )
1345     
1346  '   Dim str_TableName$
1347     Dim lng_ColumnIndex&
1348     Dim lng_DataRowsCount&
1349     
1350     Set rng_SourceRange = rng_SourceRange.CurrentRegion
1351     lng_DataRowsCount = rng_SourceRange.Rows.Count - lng_HeaderRow 'calculate number of rows below header row
1352     lng_HeaderRow = lng_HeaderRow - 1 'remove one row for ofset
1353 
1354 'reset autofilter
1355     If str_ColumnName = "" Then
1356         rng_SourceRange.AutoFilter
1357         rng_SourceRange.ShowAutoFilter = True
1358         Exit Function
1359     End If
1360     
1361 'find column index of the name of column
1362     lng_ColumnIndex = rng_SourceRange.Resize(1).Offset(lng_HeaderRow).Find(str_ColumnName).Column - (rng_SourceRange.Resize(1, 1).Column - 1)
1363     
1364 'autofilter before filtering
1365     If RemoveAutoFilter Then rng_SourceRange.AutoFilter
1366 
1367 'check if filter list is not array
1368     If TypeName(arr_Criteria) = "Range" Then arr_Criteria = RangeToArray(arr_Criteria)
1369     
1370 'check if there is not required negative autofilter
1371     If InvertedAutoFilter Then
1372         Dim arr_ColumnData
1373         arr_ColumnData = WorksheetFunction.Transpose(rng_SourceRange.Resize(lng_DataRowsCount, 1).Offset(lng_HeaderRow, lng_ColumnIndex))
1374         Call z_mArrayFilterUnique(arr_ColumnData, arr_Criteria) 'replace in arr_Criteria with all data which are in the column data and it's not in column criteria
1375     End If
1376     
1377 'DateAutofilter Criteria Array
1378     Dim arr_DateCritieria
1379     Dim i&
1380     
1381 'Date Criteria
1382     ReDim arr_DateCritieria((UBound(arr_Criteria) * 2) + 1)
1383     For i = LBound(arr_Criteria) To UBound(arr_Criteria)
1384         arr_DateCritieria(i * 2) = 2 'criteria scope taken 0-Year,1-Month,2-Day,3-Hour,4-Minute
1385         arr_DateCritieria(i * 2 + 1) = CStr(Month(arr_Criteria(i)) & "/" & Day(arr_Criteria(i)) & "/" & Year(arr_Criteria(i)))
1386     Next
1387     
1388 'apply autofilter
1389    rng_SourceRange.Resize(lng_DataRowsCount + 1).Offset(lng_HeaderRow).AutoFilter _
1390         Field:=lng_ColumnIndex, _
1391         Criteria2:=arr_DateCritieria, _
1392         Operator:=xlFilterValues
1393         
1394 End Function
1395 
1396 Private Function z_mArrayFilterUnique( _
1397                                     ByRef arr_SourceData, _
1398                                     ByRef arr_ResultData _
1399                                                             ) As Boolean
1400 
1401     z_mArrayFilterUnique = False
1402 
1403     Dim i&
1404     Dim arr_BlackListCriteria
1405     Dim arr_CriteriaTemp
1406 
1407     arr_CriteriaTemp = arr_ResultData
1408     arr_BlackListCriteria = arr_ResultData
1409 
1410     ReDim arr_ResultData(0)
1411     For i = LBound(arr_SourceData) To UBound(arr_SourceData)
1412 
1413         If Not z_mFoundInArray(arr_BlackListCriteria, arr_SourceData(i)) Then  'Not Found in Black List
1414         
1415             If Not z_mFoundInArray(arr_ResultData, arr_SourceData(i)) Then    'Not Found in Result Array means new unique value
1416                 arr_ResultData(UBound(arr_ResultData)) = CStr(arr_SourceData(i))
1417                 ReDim Preserve arr_ResultData(UBound(arr_ResultData) + 1)
1418             End If
1419     
1420         End If
1421     
1422     Next
1423 
1424     If IsEmpty(arr_ResultData(0)) Then
1425         arr_ResultData = arr_CriteriaTemp
1426     Else
1427         ReDim Preserve arr_ResultData(UBound(arr_ResultData) - 1)
1428         z_mArrayFilterUnique = True
1429     End If
1430     
1431 End Function
1432 Function TableCopyVisible( _
1433                             ByVal tbl_Object As ListObject, _
1434                             Optional ByRef arr_ColumnNames _
1435                             )
1436     Dim i&
1437     Dim str_TableName$
1438     Dim rng_TempRangeArea As Range
1439 
1440     str_TableName = tbl_Object.Name
1441 
1442     With tbl_Object.Range.Worksheet
1443 
1444         'tbl_Object.Range.AutoFilter
1445         tbl_Object.ShowAutoFilter = True
1446 
1447 
1448         If Not IsMissing(arr_ColumnNames) Then
1449             
1450             If TypeName(arr_ColumnNames) = "Range" Then arr_ColumnNames = Me.RangeToArray(arr_ColumnNames)
1451             
1452             For i = LBound(arr_ColumnNames) To UBound(arr_ColumnNames)
1453         
1454                 'combine column to one copy clipboard
1455                 If i = LBound(arr_ColumnNames) Then
1456                     Set rng_TempRangeArea = .Range(tbl_Object.Name & "[" & arr_ColumnNames(i) & "]").SpecialCells(xlCellTypeVisible)
1457                 Else
1458                     Set rng_TempRangeArea = Union(rng_TempRangeArea, .Range(tbl_Object.Name & "[" & arr_ColumnNames(i) & "]").SpecialCells(xlCellTypeVisible))
1459                 End If
1460                 
1461             Next
1462             
1463             rng_TempRangeArea.Copy
1464         
1465         Else
1466         
1467             tbl_Object.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
1468     
1469         End If
1470         
1471     End With
1472     
1473 End Function
1474 
1475 'paste on the end of the select table data from the clipboard table is automatically exteded
1476 'if there are formulas in the table outside pasted data they will recalculated
1477 'default way of data paste is values
1478 
1479 'Parameters
1480 'mandatory  r   rng_Table       Range       : enter any range with is in the table (table name)
1481 'optional   r   lng_PasteType   Option      : let selected user in which way data should be pasted
1482 
1483 Function TablePasteAppend( _
1484                             ByVal tbl_Object As ListObject, _
1485                             Optional lng_PasteType As XlPasteType = xlPasteValues _
1486                             )
1487     
1488     On Error GoTo Err
1489     
1490 'VARIABLE DEFINE
1491     
1492     Dim str_TableName$
1493     Dim lng_CopyRowsCount&
1494 
1495 
1496 
1497     str_TableName = tbl_Object.Name
1498     
1499 'INPUT CHECK
1500 'PRINTING STATE
1501     Application.StatusBar = "Pastining into table: " & str_TableName
1502     
1503     
1504 'FUNCTION ACTION
1505     With tbl_Object.Range.Offset(1).Resize(tbl_Object.Range.Rows.Count - 1)
1506      
1507         If .Rows.Count = 1 Then
1508             
1509             If .SpecialCells(xlCellTypeConstants).Rows.Count = 0 Then
1510                 lng_CopyRowsCount = 0
1511             Else
1512                 lng_CopyRowsCount = 1
1513             End If
1514         
1515         Else
1516             lng_CopyRowsCount = .Rows.Count
1517         End If
1518 
1519     End With
1520 
1521     'Consolidating ERP
1522     Dim clipboard As MSForms.DataObject
1523 
1524 
1525     Set clipboard = New MSForms.DataObject
1526     clipboard.GetFromClipboard
1527 
1528 
1529     On Error Resume Next
1530     'resize table on size of new range
1531     Call tbl_Object.Resize(tbl_Object.Range.Resize(1 + lng_CopyRowsCount + UBound(Split(clipboard.GetText, vbCrLf))))
1532 
1533 
1534     Call tbl_Object.Range.Offset(1 + lng_CopyRowsCount).Cells(1, 1).PasteSpecial(lng_PasteType)
1535 
1536     Application.StatusBar = False
1537 
1538     tbl_Object.Range.Calculate
1539 
1540     Exit Function
1541 
1542 Err:
1543 
1544     Debug.Print Err.Number
1545     Select Case Err.Number
1546         Case 1004: If Err.Description = "No cells were found." Then Resume Next
1547         Case 0
1548     End Select
1549 
1550 End Function
1551 
1552 Function TableAppendToTable( _
1553                             ByVal tbl_Copy As ListObject, _
1554                             ByVal tbl_PasteAppend As ListObject, _
1555                             Optional ByVal bool_Transpose As Boolean = False, _
1556                             Optional ByVal arr_HeaderMaskInput As Variant _
1557                             )
1558 
1559     Dim lng_CalcActions As Long
1560     
1561     Application.StatusBar = IIf(bool_Transpose, "Transposing and ", "") & "Appending table " & tbl_Copy.Name & " to " & tbl_PasteAppend.Name
1562 
1563     lng_CalcActions = Application.Calculation
1564     Application.Calculation = xlCalculationManual
1565 
1566 'CALCULATE ROWS TO COPY
1567     On Error GoTo Err
1568 
1569     Dim arr_VisibleRows()
1570     ReDim arr_VisibleRows(0)
1571     
1572    
1573 'CHECK SOURCE TABLE DATA
1574    If tbl_Copy.DataBodyRange Is Nothing Then Exit Function
1575 
1576 'PREPARE COPY
1577     Dim rng_Cursor As Range
1578     Dim arr_Copy
1579     
1580     Dim lng_RowCounter As Long
1581     Dim lng_CopyRowsCount&
1582     
1583     lng_RowCounter = 2
1584 
1585     tbl_Copy.Range.Calculate
1586 
1587     If bool_Transpose Then
1588     
1589         arr_Copy = tbl_Copy.DataBodyRange.Value2
1590         arr_Copy = WorksheetFunction.Transpose(arr_Copy)
1591     
1592         For Each rng_Cursor In tbl_Copy.HeaderRowRange.Offset(, 1).Resize(, tbl_Copy.HeaderRowRange.Count - 1)
1593             If rng_Cursor.EntireColumn.Hidden = False Then
1594                 arr_VisibleRows(UBound(arr_VisibleRows)) = lng_RowCounter
1595                 ReDim Preserve arr_VisibleRows(UBound(arr_VisibleRows) + 1)
1596             End If
1597             
1598             lng_RowCounter = lng_RowCounter + 1
1599         Next
1600     
1601     Else
1602 
1603         For Each rng_Cursor In tbl_Copy.DataBodyRange.Resize(, 1)
1604             If rng_Cursor.EntireRow.Hidden = False Then
1605                 
1606                 arr_VisibleRows(UBound(arr_VisibleRows)) = lng_RowCounter
1607                 ReDim Preserve arr_VisibleRows(UBound(arr_VisibleRows) + 1)
1608             End If
1609             
1610             lng_RowCounter = lng_RowCounter + 1
1611         Next
1612 
1613         arr_Copy = tbl_Copy.Range.Value2
1614     End If
1615     
1616     If UBound(arr_VisibleRows) = 0 Then Exit Function ' nothing to append
1617     
1618     ReDim Preserve arr_VisibleRows(UBound(arr_VisibleRows) - 1)
1619 
1620 'PREPARE PASTE
1621     Dim arr_Paste As Variant
1622     arr_Paste = tbl_PasteAppend.Range.Formula
1623     
1624     Dim arr_HeaderRelation()
1625     Dim arr_HeaderArrayFormula()
1626     
1627     Dim c_AppendCursor As Long
1628     Dim c_CopyCursor As Long
1629     
1630     Dim lng_ColumnInCopy As Long
1631     
1632     ReDim arr_HeaderRelation(1 To UBound(arr_Paste, 2))
1633     ReDim arr_HeaderArrayFormula(1 To UBound(arr_Paste, 2))
1634     
1635 'IF THERE IS DATA MASK CONVERT TABLE HEADER TO IT
1636     If Not IsMissing(arr_HeaderMaskInput) Then
1637         
1638         Dim arr_HeaderMask()
1639     
1640         arr_HeaderMask = z_mCovertToSimpleArray(arr_HeaderMaskInput)
1641             
1642         For c_AppendCursor = LBound(arr_Paste, 2) To UBound(arr_Paste, 2)
1643         
1644             If c_AppendCursor > UBound(arr_HeaderMask) + 1 Then
1645                 arr_Paste(1, c_AppendCursor) = ""
1646             Else
1647                 arr_Paste(1, c_AppendCursor) = Replace(arr_HeaderMask(c_AppendCursor - 1), "#", "'#")
1648             End If
1649             
1650         Next
1651 
1652     End If
1653     
1654     
1655     
1656 'map header
1657     For c_AppendCursor = LBound(arr_Paste, 2) To UBound(arr_Paste, 2)
1658         
1659         lng_ColumnInCopy = -1
1660         
1661     'SEARCHING LOOP
1662         For c_CopyCursor = LBound(arr_Copy, 2) To UBound(arr_Copy, 2)
1663             If arr_Paste(1, c_AppendCursor) = arr_Copy(1, c_CopyCursor) Then
1664                 lng_ColumnInCopy = c_CopyCursor
1665                 Exit For 'Found
1666             End If
1667         Next
1668     
1669         arr_HeaderArrayFormula(c_AppendCursor) = tbl_PasteAppend.HeaderRowRange.Resize(1, 1).Offset(1, c_AppendCursor - 1).HasArray
1670         arr_HeaderRelation(c_AppendCursor) = lng_ColumnInCopy
1671     
1672     Next
1673     
1674     Dim lng_AppendRows As Long
1675     lng_AppendRows = UBound(arr_Paste)
1676     
1677     'traspose array
1678     Dim arr_Append()
1679     ReDim arr_Append(1 To UBound(arr_VisibleRows) + 1, 1 To UBound(arr_Paste, 2))
1680 
1681     For c_AppendCursor = LBound(arr_HeaderRelation) To UBound(arr_HeaderRelation)
1682         
1683         If arr_HeaderRelation(c_AppendCursor) <> "-1" Then
1684             
1685             For c_CopyCursor = LBound(arr_VisibleRows) To UBound(arr_VisibleRows)
1686                 arr_Append(c_CopyCursor + 1, c_AppendCursor) = arr_Copy(arr_VisibleRows(c_CopyCursor), arr_HeaderRelation(c_AppendCursor))
1687             Next
1688         Else
1689             
1690             If arr_Paste(2, c_AppendCursor) Like "=*" Then 'extend formula
1691             
1692                 For c_CopyCursor = LBound(arr_VisibleRows) To UBound(arr_VisibleRows)
1693                     arr_Append(c_CopyCursor + 1, c_AppendCursor) = arr_Paste(2, c_AppendCursor)
1694                 Next
1695             
1696             End If
1697 
1698         End If
1699     
1700     Next
1701 
1702 
1703     Dim lng_PasteOffset As Long
1704     Dim lng_PasteResize As Long
1705 
1706     If tbl_PasteAppend.Range.Rows.Count = 2 Then
1707 
1708         If tbl_PasteAppend.HeaderRowRange.Offset(1).SpecialCells(xlCellTypeConstants).Count = 0 Then
1709             lng_PasteResize = 1
1710         Else
1711             lng_PasteResize = 0
1712         End If
1713     End If
1714 
1715     'End With
1716     
1717     
1718     Dim rng_AppendArea As Range
1719     
1720     Set rng_AppendArea = tbl_PasteAppend.Range.Offset(tbl_PasteAppend.Range.Rows.Count - lng_PasteResize).Resize(UBound(arr_Append))
1721     
1722     'RESIZE PASTE TABLE
1723     Call tbl_PasteAppend.Resize(tbl_PasteAppend.Range.Resize((UBound(arr_Paste) - lng_PasteResize) + (UBound(arr_VisibleRows) + 1)))
1724     
1725     
1726     rng_AppendArea = arr_Append
1727     
1728     
1729     'CHECK IF THERE WAS ANY ARRAY FORMULAS
1730     For c_AppendCursor = LBound(arr_HeaderArrayFormula) To UBound(arr_HeaderArrayFormula)
1731         If arr_HeaderArrayFormula(c_AppendCursor) And arr_HeaderRelation(c_AppendCursor) = -1 Then
1732             rng_AppendArea.Resize(1, 1).Offset(, c_AppendCursor - 1).FormulaArray = arr_Paste(2, c_AppendCursor)
1733             rng_AppendArea.Resize(, 1).Offset(, c_AppendCursor - 1).FillDown
1734         End If
1735     Next
1736     
1737     rng_AppendArea.Calculate
1738 
1739     DoEvents
1740     DoEvents
1741 
1742     Application.StatusBar = False
1743 
1744     Exit Function
1745 Err:
1746   
1747     Debug.Print Err.Number & Err.Description
1748     Select Case Err.Number
1749         Case 1004: If Err.Description = "No cells were found." Then Resume Next
1750         Case 0
1751     End Select
1752   'Resume
1753 End Function
1754 
1755 Function TableSort( _
1756                     ByVal tbl_Object As ListObject, _
1757                     ByRef str_ColumnName$, _
1758                     ByRef Orientation As XlSortOrder _
1759                     )
1760 
1761     Application.StatusBar = "Sorting table " & tbl_Object.Name & " in Column " & str_ColumnName & IIf(Orientation = xlAscending, " ascending", " descending")
1762 
1763     With tbl_Object.Sort
1764     
1765         .SortFields.Clear
1766         .SortFields.Add _
1767             Key:=tbl_Object.Range.Worksheet.Range(tbl_Object.Name & "[[#All],[" & Replace(str_ColumnName, "#", "'#") & "]]"), _
1768             SortOn:=xlSortOnValues, _
1769             Order:=Orientation, _
1770             DataOption:=xlSortNormal
1771     
1772         .Header = xlYes
1773         .MatchCase = False
1774         .Orientation = xlTopToBottom
1775         .SortMethod = xlPinYin
1776         .Apply
1777     End With
1778 
1779     Application.StatusBar = False
1780 
1781 End Function
1782 
1783 Function TableRemoteRefresh( _
1784                             ByVal tbl_Object As ListObject _
1785                                                             ) As Boolean
1786     On Error Resume Next
1787     
1788     Application.StatusBar = "Refreshing remote data in table " & tbl_Object.Name
1789 
1790     Call tbl_Object.QueryTable.Refresh(BackgroundQuery:=False)
1791 
1792     Call tbl_Object.Range.Calculate
1793 
1794 End Function
1795 
1796 Function TableToCSV( _
1797                         ByVal tbl_Object As ListObject, _
1798                         Optional ByRef str_FileName As String = "", _
1799                         Optional ByRef str_Path As String = "", _
1800                         Optional ByRef str_Separator As String = "|", _
1801                         Optional ByRef bool_AddSeparatorLine As Boolean = False, _
1802                         Optional ByRef bool_IncludeHeader As Boolean = True, _
1803                         Optional ByRef bool_ClearDummyHeaders As Boolean = False _
1804                                                                     ) As Boolean
1805 
1806 'CHECK DATA INPUT
1807     If str_FileName = "" Then str_FileName = tbl_Object.Name
1808     If str_Path = "" Then str_Path = tbl_Object.Range.Worksheet.Parent.Path
1809 
1810     str_FileName = str_FileName & ".csv"
1811 
1812 'VARIABLE
1813 
1814     Dim rng_Cursor As Range
1815     Dim rng_Data As Range
1816     Dim lng_ColumnsCount As Long
1817     Dim arr_Source()
1818     
1819     'check if there are any data in the range
1820     On Error Resume Next
1821         If bool_IncludeHeader Then
1822             Set rng_Data = tbl_Object.Range
1823         Else
1824             Set rng_Data = tbl_Object.DataBodyRange
1825         End If
1826     On Error GoTo 0
1827     
1828     If rng_Data Is Nothing Then
1829         Exit Function
1830     End If
1831 
1832     
1833 
1834     arr_Source = rng_Data.Value
1835     
1836     Dim r_Cursor As Long
1837     Dim c_Cursor As Long
1838     
1839     'Clearing Dummy headers
1840     If bool_ClearDummyHeaders Then
1841         For c_Cursor = 1 To UBound(arr_Source, 2)
1842             If arr_Source(1, c_Cursor) Like "Dummy*" Then arr_Source(1, c_Cursor) = ""
1843         Next
1844     End If
1845     
1846     
1847     Dim arr_RowTemp()
1848     Dim arr_ItemsTemp()
1849     
1850     ReDim arr_RowTemp(1 To UBound(arr_Source, 1))
1851     ReDim arr_ItemsTemp(1 To UBound(arr_Source, 2))
1852     
1853     
1854     For r_Cursor = 1 To UBound(arr_Source, 1)
1855         For c_Cursor = 1 To UBound(arr_Source, 2)
1856              arr_ItemsTemp(c_Cursor) = arr_Source(r_Cursor, c_Cursor)
1857         Next
1858         
1859         arr_RowTemp(r_Cursor) = Join(arr_ItemsTemp, str_Separator)
1860     Next
1861 
1862     Dim file_Output As Object
1863 
1864     With CreateObject("Scripting.FileSystemObject")
1865     
1866         'write file
1867         Set file_Output = .CreateTextFile(str_Path & "\" & str_FileName, True)
1868       
1869         Call file_Output.WriteLine(IIf(bool_AddSeparatorLine, "sep=" & str_Separator & vbCrLf, "") & Join(arr_RowTemp, vbCrLf))
1870         Call file_Output.Close
1871 
1872     End With
1873 
1874 End Function
1875 
1876 Function TableSharePointLoad( _
1877     ByRef tbl_Object As ListObject, _
1878     ByVal str_Path As String, _
1879     ByVal str_ListId As String, _
1880     ByVal str_ViewId As String)
1881 
1882     On Error GoTo Err:
1883 
1884     Dim str_Name As String
1885   '  Dim WorksheetFunction
1886     Dim rng_Address As Range
1887 
1888     
1889     str_Name = tbl_Object.Name
1890     Set rng_Address = tbl_Object.Range.Resize(1, 1)
1891     
1892     tbl_Object.Delete
1893 
1894     Dim src(2) As Variant
1895     src(0) = str_Path
1896     src(1) = str_ListId
1897     src(2) = str_ViewId
1898 
1899 
1900     Set tbl_Object = rng_Address.Worksheet.ListObjects.Add(xlSrcExternal, src, True, xlYes, rng_Address)
1901 
1902     GoTo RunExit
1903     
1904 Err:
1905 
1906     Set tbl_Object = rng_Address.Worksheet.ListObjects.Add(, , , , rng_Address)
1907 
1908 RunExit:
1909 
1910      tbl_Object.Name = str_Name
1911 End Function
1912 
1913 Function TableSharepointSave(ByRef tbl_Object As ListObject)
1914 
1915     tbl_Object.UpdateChanges xlListConflictDialog '
1916     
1917 End Function
1918 
1919 'Obsolete naming Left for Compatibilty
1920 Function TableColumnLoop( _
1921                             ByRef tbl_SourceTable As ListObject, _
1922                             Optional ByRef rng_Cursor As Range = Nothing, _
1923                             Optional ByRef str_ColumnName As String = "", _
1924                             Optional ByVal lng_SpecialCells As XlCellType = 0 _
1925                                                                                 ) As Boolean
1926 
1927    TableColumnLoop = TableLoop(tbl_SourceTable, rng_Cursor, str_ColumnName, lng_SpecialCells)
1928 
1929 End Function
1930 
1931 Function TableLoop( _
1932     ByRef tbl_SourceTable As ListObject, _
1933     Optional ByRef rng_Cursor, _
1934     Optional ByVal str_ColumnName As String = "", _
1935     Optional ByVal lng_SpecialCells As e_TableLoopTypes = 0, _
1936     Optional ByVal bool_RemoveFilters As e_ResetFilter = e_LeaveCurrentFilters _
1937         ) As Boolean
1938 
1939 On Error GoTo Err:
1940 
1941 'VARIABLES
1942     TableLoop = False
1943     Dim str_TableKey As String
1944     Dim str_ColumnKey As String
1945     Dim cc_Cursors As Collection
1946       
1947 'CREATE UNIQUE KEY TABLE SCOPE FILENAME + TABLENAME
1948     str_TableKey = tbl_SourceTable.Range.Worksheet.Parent.FullName & tbl_SourceTable.Name
1949     
1950 'INIT  GLOBAL COLLECTION STORAGE
1951     If cc_TableLoopHeaders Is Nothing Then
1952         Set cc_TableLoopHeaders = New Collection 'storage of the table headers
1953         Set cc_TableLoopCursors = New Collection
1954         GoTo NEW_ITEM
1955     End If
1956 
1957 'CHECK IF TABLE ALREADY INITIATED IN THE LOOP
1958     If Not z_mKeyExists(cc_TableLoopHeaders, str_TableKey) Then GoTo NEW_ITEM
1959     
1960 'CREATE UNIQUE KEY COLUMN SCOPE FILENAME + TABLENAME + COLUMN
1961     If str_ColumnName = "" Then str_ColumnName = tbl_SourceTable.HeaderRowRange.Resize(1, 1) 'this could be issue in multiple loop in one table casses
1962     
1963     str_ColumnKey = str_TableKey + str_ColumnName
1964     
1965 'CHECK IF TABLE WITH COLUMN IS ALREADY INITIATED
1966     If z_mKeyExists(cc_TableLoopCursors, str_ColumnKey) Then GoTo EXISTING_ITEM
1967     
1968 NEW_ITEM:
1969 'NEW ITEM => CREATE NEW COLLECTION AND START THE LOOP
1970 
1971     Dim cc_ColumnHeadersRelative As Collection
1972     Dim cc_ColumnHeadersAbsolute As Collection
1973     
1974     Dim cc_RowNumbers As Collection
1975 
1976     Dim lng_ColumnCounter As Long
1977     Dim rng_HeaderCursor As Range
1978 
1979     Set cc_ColumnHeadersRelative = New Collection 'table scope
1980     Set cc_ColumnHeadersAbsolute = New Collection 'table scope
1981     
1982     Set cc_RowNumbers = New Collection 'delete
1983     Set cc_Cursors = New Collection 'table column scope
1984 
1985     lng_ColumnCounter = 0
1986     
1987     'Cache Headers
1988     For Each rng_HeaderCursor In tbl_SourceTable.HeaderRowRange
1989         lng_ColumnCounter = lng_ColumnCounter + 1
1990         Call cc_ColumnHeadersRelative.Add(lng_ColumnCounter, rng_HeaderCursor.Value)
1991         Call cc_ColumnHeadersAbsolute.Add(rng_HeaderCursor.Column, rng_HeaderCursor.Value)
1992     Next
1993     
1994     'COLUMN PICK add scope check
1995     If str_ColumnName <> "" Then lng_ColumnCounter = cc_ColumnHeadersRelative.Item(str_ColumnName) Else lng_ColumnCounter = 1
1996 
1997     Dim lng_SpecialCellsTemp As Long
1998             
1999     Select Case lng_SpecialCells
2000         Case e_UniquesWithFilter: lng_SpecialCellsTemp = xlCellTypeVisible
2001         Case e_Uniques: lng_SpecialCellsTemp = xlCellTypeConstants 'never used as 0 type not using specialcells function
2002         Case e_Visible: lng_SpecialCellsTemp = xlCellTypeVisible
2003         Case e_Blanks: lng_SpecialCellsTemp = xlCellTypeBlanks
2004         Case e_Formulas: lng_SpecialCellsTemp = xlCellTypeFormulas
2005         Case e_NonBlanks: lng_SpecialCellsTemp = xlCellTypeConstants
2006     End Select
2007     
2008     'LOAD ROWS IN TABLE
2009     Dim rng_Data As Range
2010     On Error Resume Next
2011         If lng_SpecialCells = 0 Then
2012             Set rng_Data = tbl_SourceTable.DataBodyRange.Resize(, 1).Offset(, lng_ColumnCounter - 1) 'pick first column
2013         Else
2014 
2015             Set rng_Data = tbl_SourceTable.DataBodyRange.SpecialCells(lng_SpecialCellsTemp)
2016 
2017             If Not rng_Data Is Nothing Then
2018                 Set rng_Data = tbl_SourceTable.DataBodyRange.Resize(, 1).Offset(, lng_ColumnCounter - 1).SpecialCells(lng_SpecialCellsTemp)
2019             End If
2020         End If
2021     On Error GoTo Err
2022     
2023     If rng_Data Is Nothing Then
2024         Exit Function
2025     End If
2026 
2027     'INDEX ROW NUMBERS AND COLLECTIONS
2028     Dim rng_RowCursor As Range
2029 
2030     'CLEAR AUTOFILTER FIRST
2031     If bool_RemoveFilters Then Call TableAutofilter(tbl_SourceTable)
2032 
2033     'ADD ITEMS PICK-CHECK WITH UNIQUE
2034     If lng_SpecialCells = e_UniquesWithFilter Or lng_SpecialCells = e_Uniques Then
2035         Dim cc_Uniques As Collection
2036         Set cc_Uniques = New Collection
2037 
2038         For Each rng_RowCursor In rng_Data
2039             If Not z_mKeyExists(cc_Uniques, CStr(rng_RowCursor.Value)) Then
2040                 Call cc_Uniques.Add(Null, CStr(rng_RowCursor.Value))
2041                 Call cc_Cursors.Add(rng_RowCursor)
2042             End If
2043         Next
2044     Else
2045     
2046         For Each rng_RowCursor In rng_Data
2047             Call cc_Cursors.Add(rng_RowCursor)
2048         Next
2049         
2050     End If
2051         
2052     'if collection not initiated yet initiate them
2053     'DEFINE COLUMN KEY
2054     If str_ColumnName = "" Then str_ColumnName = tbl_SourceTable.HeaderRowRange.Resize(1, 1) 'this could be issue in multiple loop in one table casses
2055     str_ColumnKey = str_TableKey + str_ColumnName
2056 
2057     If z_mKeyExists(cc_TableLoopHeaders, str_TableKey) Then _
2058         Call cc_TableLoopHeaders.Remove(str_TableKey)
2059 
2060     If z_mKeyExists(cc_TableLoopCursors, str_ColumnKey) Then _
2061         Call cc_TableLoopCursors.Remove(str_ColumnKey)
2062 
2063     Call cc_TableLoopHeaders.Add(cc_ColumnHeadersAbsolute, str_TableKey)
2064     Call cc_TableLoopCursors.Add(cc_Cursors, str_ColumnKey)
2065     
2066 EXISTING_ITEM:
2067 'EXISTING_ITEM => JUST GO TO ANOTHER IN LOOP
2068 
2069     'DEFINING INNER CLASS
2070     Set cc_Cursors = cc_TableLoopCursors.Item(str_ColumnKey)
2071 
2072     'END OF LOOP CASE => RESET CHECK ACTION
2073     If cc_Cursors.Count = 0 Then 'everything looped exit function
2074         Call cc_TableLoopCursors.Remove(str_ColumnKey)  'reset
2075         Call TableAutofilter(tbl_SourceTable, str_ColumnName)
2076         Exit Function
2077     End If
2078     
2079     'SETTING NEW CURSOR
2080     Set rng_Cursor = cc_Cursors.Item(1)
2081     Call cc_Cursors.Remove(1) 'remove used cursor from collection
2082     
2083     If lng_SpecialCells = e_UniquesWithFilter Then
2084         Call TableAutofilter(tbl_SourceTable, str_ColumnName, rng_Cursor, , e_LeaveCurrentFilters)
2085     End If
2086     
2087     TableLoop = True
2088 
2089     Exit Function
2090 Err:
2091 
2092     Err.Raise Err.Number
2093     Resume
2094 
2095 End Function
2096 
2097 Function TableLoopCursor( _
2098     ByRef rng_Cursor As Range, _
2099     ByRef str_ColumnName As String _
2100         ) As Range
2101 
2102     Dim str_TableKey As String
2103     
2104 'CHECK DATA INPUT
2105     str_TableKey = rng_Cursor.Worksheet.Parent.FullName & rng_Cursor.ListObject
2106 
2107 
2108     'check if table exists
2109     If Not z_mKeyExists(cc_TableLoopHeaders, str_TableKey) Then Exit Function
2110     
2111     'Dim lng_ItemCursor As Long
2112     'Dim lng_Row As Long
2113     'Dim lng_Column As Long
2114 
2115     'lng_ItemCursor = cc_LoopedRangesIndexes.Item(str_DirPath & tbl_SourceTable.Name)
2116 
2117     'lng_Row = cc_TableLoopCursors.Item(str_DirPath & tbl_SourceTable.Name).Item(lng_ItemCursor - 1)
2118     'lng_Column = cc_TableLoopHeaders.Item(str_DirPath & tbl_SourceTable.Name).Item(str_ColumnName) - 1
2119     
2120     'Set TableLoopCursor = tbl_SourceTable.Range.Resize(1, 1).Offset(lng_Row, lng_Column)
2121 
2122     Set TableLoopCursor = rng_Cursor.Offset(0, cc_TableLoopHeaders.Item(str_TableKey).Item(str_ColumnName) - rng_Cursor.Column)
2123 
2124 End Function
2125 
2126 
2127 Function RangeToArray( _
2128     ByRef rng_Input As Variant _
2129         ) As Variant
2130 
2131     If rng_Input.Rows.Count > 1 And rng_Input.Columns.Count = 1 Then
2132         RangeToArray = WorksheetFunction.Transpose(rng_Input.Value2)
2133     End If
2134     
2135     If rng_Input.Columns.Count > 1 And rng_Input.Rows.Count = 1 Then
2136         RangeToArray = WorksheetFunction.Index(rng_Input.Value2, 0)
2137     End If
2138   
2139     If rng_Input.Columns.Count = 1 And rng_Input.Rows.Count = 1 Then
2140         RangeToArray = Array(rng_Input.Value2)
2141     End If
2142   
2143 End Function
2144 
2145 Function WorkbookByCopySheets( _
2146     ByRef wbk_Result As Workbook, _
2147     ByRef arr_SheetNamesInput, _
2148     ByVal str_NewWorkbookName As String, _
2149     Optional ByRef str_SaveWorkBookToPath$, _
2150     Optional ByRef wbk_Source As Workbook, _
2151     Optional bool_BreakLinks As Boolean = True, _
2152     Optional bool_RemoveMacros As Boolean = True _
2153         ) As Boolean
2154 
2155     WorkbookByCopySheets = False
2156 
2157 On Error GoTo Exit_Function
2158 
2159     'Call z_mCovertToSimpleArray(arr_SheetNames)
2160     Dim arr_SheetNames
2161     arr_SheetNames = z_mCovertToSimpleArray(arr_SheetNamesInput)
2162 
2163     If wbk_Source Is Nothing Then Set wbk_Source = ThisWorkbook
2164     If str_SaveWorkBookToPath = "" Then str_SaveWorkBookToPath = wbk_Source.Path
2165     
2166     'Application.ScreenUpdating = False
2167     
2168     'save workbook
2169     wbk_Source.Save
2170    
2171     'enter suffix to the file
2172     str_NewWorkbookName = str_NewWorkbookName & "." & Split(wbk_Source.Name, ".")(1)
2173     
2174     'Check if workbook is not open
2175     Dim i_WorkbooksCursor As Long
2176     
2177     For i_WorkbooksCursor = 1 To Application.Workbooks.Count
2178         If Application.Workbooks(i_WorkbooksCursor).Name = str_NewWorkbookName Then
2179             Call MsgBox("Workbook with name " & str_NewWorkbookName & " is now open. Can't open another one", vbCritical, "Error")
2180             Exit Function
2181         End If
2182     Next
2183 
2184     'prepare workbook path
2185     Dim str_NewWorkbookPathTemp$
2186     str_NewWorkbookPathTemp = str_SaveWorkBookToPath & "\" & str_NewWorkbookName
2187     
2188     'copy current to new file
2189     Dim fs As Object
2190     Dim oldPath As String, newPath As String
2191     oldPath = wbk_Source.FullName 'Folder file is located in
2192     newPath = str_NewWorkbookPathTemp 'Folder to copy file to
2193     Set fs = CreateObject("Scripting.FileSystemObject")
2194     fs.CopyFile oldPath, newPath   'This file was an .xls file
2195     Set fs = Nothing
2196 
2197 
2198     Dim bool_UpdateLinksTemp As Boolean
2199 
2200     bool_UpdateLinksTemp = Application.AskToUpdateLinks
2201     Application.AskToUpdateLinks = False
2202     'Application.DisplayAlerts = False
2203     'open the file
2204     Set wbk_Result = Workbooks.Open(str_NewWorkbookPathTemp)
2205 
2206     Application.AskToUpdateLinks = bool_UpdateLinksTemp
2207     'Application.DisplayAlerts = True
2208 
2209     Dim i&
2210     Dim sht_Cursor As Worksheet
2211     Dim bool_SheetFound As Boolean
2212 
2213     'check what sheets should be deleted
2214     For Each sht_Cursor In wbk_Result.Worksheets
2215         bool_SheetFound = False
2216         For i = LBound(arr_SheetNames) To UBound(arr_SheetNames)
2217             If sht_Cursor.Name = arr_SheetNames(i) Then
2218                 bool_SheetFound = True
2219             End If
2220         Next
2221         'Application.DisplayAlerts = False
2222         If bool_SheetFound = False Then sht_Cursor.Delete
2223         'Application.DisplayAlerts = True
2224     Next
2225 
2226     'remove all links which remains by default
2227     If bool_BreakLinks Then
2228         Dim arr_Links As Variant
2229         Dim i_LinkCursor As Long
2230         arr_Links = wbk_Result.LinkSources(Type:=xlLinkTypeExcelLinks)
2231         If arr_Links <> Empty Then
2232             For i_LinkCursor = 1 To UBound(arr_Links)
2233                 Call wbk_Result.BreakLink( _
2234                     Name:=arr_Links(i_LinkCursor), _
2235                     Type:=xlLinkTypeExcelLinks)
2236             Next i_LinkCursor
2237         End If
2238     End If
2239 
2240     
2241     If bool_RemoveMacros Then
2242         Dim str_WorkbookTempPath As String
2243         Call wbk_Result.SaveAs(, xlOpenXMLWorkbook)
2244         str_WorkbookTempPath = wbk_Result.FullName
2245         wbk_Result.Close
2246         Set wbk_Result = Workbooks.Open(str_WorkbookTempPath)
2247         Call wbk_Result.SaveAs(, xlExcel12)
2248         Kill str_WorkbookTempPath
2249     End If
2250 
2251     WorkbookByCopySheets = True
2252     
2253 Exit_Function:
2254 
2255     If Err.Number <> 0 Then
2256 
2257         Err.Raise Err.Number, Err.Source, Err.Description
2258     End If
2259 
2260 End Function
2261 
2262 Function TableRemoveDuplicates( _
2263     ByVal tbl_Object As ListObject, _
2264     Optional ByRef arr_ColumnsCriteriaInput _
2265         )
2266 
2267 
2268     Dim str_TableName$
2269 
2270 
2271     str_TableName = tbl_Object.Name
2272 
2273     Dim i&
2274     Dim arr_FunctionCriteria()
2275     Dim lng_TopLeftColumn&
2276     Dim arr_ColumnsCriteria()
2277 
2278     If Not IsMissing(arr_ColumnsCriteriaInput) Then
2279         
2280         'DEFIN TOP LEFT COLUMN
2281         lng_TopLeftColumn = tbl_Object.Range.Resize(1, 1).Column
2282         
2283         arr_ColumnsCriteria = z_mCovertToSimpleArray(arr_ColumnsCriteriaInput)
2284         
2285         'If TypeName(arr_ColumnsCriteria) = "Range" Then arr_ColumnsCriteria = Me.RangeToArray(arr_ColumnsCriteria)
2286         
2287         ReDim arr_FunctionCriteria(0)
2288         
2289         For i = LBound(arr_ColumnsCriteria) To UBound(arr_ColumnsCriteria)
2290 
2291             arr_FunctionCriteria(UBound(arr_FunctionCriteria)) = tbl_Object.HeaderRowRange.Find(CStr(arr_ColumnsCriteria(i))).Column - (tbl_Object.HeaderRowRange.Resize(, 1).Column - 1)
2292             
2293             If i <> UBound(arr_ColumnsCriteria) Then
2294                  ReDim Preserve arr_FunctionCriteria(UBound(arr_FunctionCriteria) + 1)
2295             End If
2296             
2297         Next
2298 
2299         Call tbl_Object.Range.RemoveDuplicates(Columns:=CVar(arr_FunctionCriteria), Header:=xlYes)
2300 
2301     Else
2302     
2303         ReDim arr_FunctionCriteria(tbl_Object.HeaderRowRange.Count - 1)
2304     
2305         For i = 0 To tbl_Object.HeaderRowRange.Count - 1
2306             arr_FunctionCriteria(i) = i + 1
2307         Next
2308     
2309         Call tbl_Object.Range.RemoveDuplicates(Columns:=CVar(arr_FunctionCriteria), Header:=xlYes)
2310 
2311     End If
2312 
2313 
2314 End Function
2315 
2316 Function RangeRemoveDuplicates( _
2317     ByRef rng_SourceRange As Range, _
2318     Optional lng_HeaderRows& = 1, _
2319     Optional ByRef arr_ColumnsCriteria _
2320     )
2321 
2322 
2323     Dim i&
2324     Dim arr_FunctionCriteria()
2325     Dim lng_TopLeftColumn&
2326 
2327     Set rng_SourceRange = rng_SourceRange.CurrentRegion
2328     
2329     Dim lng_CopyRowsCount&
2330     
2331     lng_CopyRowsCount = rng_SourceRange.CurrentRegion.Rows.Count - lng_HeaderRows
2332 
2333 
2334     If Not IsMissing(arr_ColumnsCriteria) Then
2335         
2336         'DEFIN TOP LEFT COLUMN
2337         lng_TopLeftColumn = rng_SourceRange.Resize(1, 1).Column + 2
2338         
2339         If TypeName(arr_ColumnsCriteria) = "Range" Then arr_ColumnsCriteria = Me.RangeToArray(arr_ColumnsCriteria)
2340         
2341         ReDim arr_FunctionCriteria(0)
2342         
2343         For i = LBound(arr_ColumnsCriteria) To UBound(arr_ColumnsCriteria)
2344 
2345            arr_FunctionCriteria(UBound(arr_FunctionCriteria)) = lng_TopLeftColumn - rng_SourceRange.Resize(1).Find(CStr(arr_ColumnsCriteria(i))).Column
2346             
2347            If i <> UBound(arr_ColumnsCriteria) Then
2348                 ReDim Preserve arr_FunctionCriteria(UBound(arr_FunctionCriteria) + 1)
2349            End If
2350             
2351         Next
2352     
2353         Call rng_SourceRange.RemoveDuplicates(Columns:=CVar(arr_FunctionCriteria), Header:=xlYes)
2354     Else
2355     
2356         Call rng_SourceRange.RemoveDuplicates(Header:=xlYes)
2357     End If
2358 
2359 End Function
2360 
2361 
2362 Function RemoveColumnsByRow( _
2363     ByRef rngRow As Range, _
2364     ByVal lng_SpecialCell As XlCellType _
2365         )
2366 
2367 
2368     rngRow.SpecialCells(lng_SpecialCell).EntireColumn.Delete
2369 
2370 End Function
2371 
2372 Function RemoveRowsByColumn( _
2373     ByRef rngColumn As Range, _
2374     ByVal lng_SpecialCell As XlCellType _
2375         )
2376 
2377 
2378     rngColumn.SpecialCells(lng_SpecialCell).EntireRow.Delete
2379 
2380 End Function
2381 
2382 'put to copy mode range of all cells which are neighbors with each other and with the defined
2383 'cell in sourcerange parameter
2384 'its allways as square selection
2385 'there is possible to difine header row to identify in where table data starts
2386 'other option is enter array of header names to put to copy only selected columns if this is
2387 'avoid all data are copied
2388 
2389 'Parameters
2390 'mandatory  r   rng_SourceRange Range       : enter one of the cell of the source data
2391 'optional   r   lng_HeaderRows  Long        : enter define line in selecte data range where is header
2392 'optional   r   arr_ColumnNames Array       : array with names of headers to be copied
2393 
2394 Function RangeCopyWithoutHeader( _
2395     ByRef rng_SourceRange As Range, _
2396     Optional lng_HeaderRows& = 1, _
2397     Optional ByRef arr_ColumnNames _
2398         )
2399 
2400 
2401     Dim lng_CopyRowsCount&
2402     
2403     lng_CopyRowsCount = rng_SourceRange.CurrentRegion.Rows.Count - lng_HeaderRows
2404     
2405     'check columns to copy
2406     Dim rng_TempRangeArea As Range
2407     Dim rng_HeaderCursor As Range
2408     Dim i& 'array index
2409     
2410     If Not IsMissing(arr_ColumnNames) Then
2411         
2412         If TypeName(arr_ColumnNames) = "Range" Then arr_ColumnNames = Me.RangeToArray(arr_ColumnNames)
2413         
2414         For i = LBound(arr_ColumnNames) To UBound(arr_ColumnNames)
2415     
2416             'combine column to one copy clipboard
2417             If i = LBound(arr_ColumnNames) Then
2418                 Set rng_TempRangeArea = rng_SourceRange.CurrentRegion.Offset(lng_HeaderRows - 1).Resize(1).Find(arr_ColumnNames(i)).Offset(1).Resize(lng_CopyRowsCount)
2419             Else
2420                 Set rng_TempRangeArea = Union(rng_TempRangeArea, rng_SourceRange.CurrentRegion.Offset(lng_HeaderRows - 1).Resize(1).Find(arr_ColumnNames(i)).Offset(1).Resize(lng_CopyRowsCount))
2421             End If
2422             
2423         Next
2424         
2425         rng_TempRangeArea.Copy
2426     
2427     Else
2428         rng_SourceRange.CurrentRegion.Offset(lng_HeaderRows).Resize(lng_CopyRowsCount).Copy
2429     
2430     End If
2431 
2432 End Function
2433 
2434 Function TableCopy( _
2435     ByVal tbl_Object As ListObject, _
2436     Optional ByRef arr_ColumnNames _
2437         )
2438         
2439 
2440     Dim i&
2441     Dim str_TableName$
2442     Dim rng_TempRangeArea As Range
2443 
2444     str_TableName = tbl_Object.Name
2445 
2446     With tbl_Object.Range.Worksheet
2447 
2448         tbl_Object.Range.AutoFilter
2449         tbl_Object.ShowAutoFilter = True
2450 
2451 
2452         If Not IsMissing(arr_ColumnNames) Then
2453             
2454             If TypeName(arr_ColumnNames) = "Range" Then arr_ColumnNames = Me.RangeToArray(arr_ColumnNames)
2455             
2456             For i = LBound(arr_ColumnNames) To UBound(arr_ColumnNames)
2457         
2458                 'combine column to one copy clipboard
2459                 If i = LBound(arr_ColumnNames) Then
2460                     Set rng_TempRangeArea = .Range(z_mTableColumn(tbl_Object, arr_ColumnNames(i)))
2461                 Else
2462                     Set rng_TempRangeArea = Union(rng_TempRangeArea, .Range(z_mTableColumn(tbl_Object, arr_ColumnNames(i))))
2463                 End If
2464                 
2465             Next
2466             
2467             
2468             
2469             rng_TempRangeArea.Copy
2470         
2471         Else
2472         
2473             tbl_Object.DataBodyRange.Copy
2474     
2475         End If
2476         
2477     End With
2478     
2479 End Function
2480 
2481 Private Function z_mTableColumn( _
2482     ByVal tbl_Object As ListObject, _
2483     ByVal var_ColumnName As Variant _
2484         ) As String
2485 
2486     If IsNumeric(var_ColumnName) Then
2487         var_ColumnName = tbl_Object.HeaderRowRange.Resize(, 1).Offset(, var_ColumnName).Value
2488     End If
2489 
2490     If InStr(1, var_ColumnName, "#") > 0 Then
2491         z_mTableColumn = tbl_Object.Name & "[" & Replace(var_ColumnName, "#", "'#") & "]"
2492     Else
2493         z_mTableColumn = tbl_Object.Name & "[" & var_ColumnName & "]"
2494     End If
2495 
2496 End Function
2497 
2498 Function RangeReOrderColumns( _
2499     ByRef rng_SourceRange As Range, _
2500     Optional lng_HeaderRows& = 1, _
2501     Optional ByRef arr_ColumnNames _
2502         )
2503 
2504 
2505     If IsMissing(arr_ColumnNames) Then Exit Function
2506 
2507     Dim lng_CopyRowsCount&
2508     
2509     lng_CopyRowsCount = rng_SourceRange.CurrentRegion.Rows.Count - lng_HeaderRows
2510     
2511     'check columns to copy
2512     Dim rng_TempRangeArea As Range
2513     Dim rng_HeaderCursor As Range
2514     Dim i& 'array index
2515     
2516     Dim str_FirstColumnAddress$
2517     
2518     If TypeName(arr_ColumnNames) = "Range" Then arr_ColumnNames = Me.RangeToArray(arr_ColumnNames)
2519     
2520     str_FirstColumnAddress = rng_SourceRange.Resize(, 1).EntireColumn.AddressLocal
2521     
2522     For i = UBound(arr_ColumnNames) To LBound(arr_ColumnNames) Step -1
2523 
2524         'cut and insert
2525         rng_SourceRange.CurrentRegion.Offset(lng_HeaderRows - 1).Resize(1).Find(arr_ColumnNames(i)).Resize(lng_CopyRowsCount + lng_HeaderRows).Cut
2526         rng_SourceRange.Worksheet.Columns(str_FirstColumnAddress).Insert Shift:=xlToRight
2527        
2528     Next
2529 
2530 
2531 End Function
2532 
2533 
2534 'TO BE REMOVED
2535 'Function OpenWorkbook( _
2536 '                        ByRef wbk_Source As Workbook, _
2537 '                        Optional ByVal str_Path$ = "", _
2538 '                        Optional ByVal str_DialogHeader _
2539 '                                                        ) As Boolean
2540 '
2541 '    'for compatibility with old versions of ATk
2542 '    OpenWorkbook = WorkbookOpen(wbk_Source, , , str_DialogHeader)
2543 '
2544 'End Function
2545 
2546 
2547 'This function takes care about opening workbook there is several enchantements against original version
2548 '-if no path parameter is inserted File dialog is automatically open in workbook location
2549 '-if path parameter is added without file dialog file dialog is open in that location
2550 '-if no file selected in file dialog it ask for again selection
2551 '-text parameter for changing header of the window
2552 '-returns true/false by sitation if succesfully oppened workbook or not
2553 
2554 'Parameters
2555 'mandatory  rw  wbk_Source      workbook    : returns shortcut on the opened workbook
2556 'optional   r   str_FileName    string      : enter workbook name to search
2557 'optional   r   str_DirPath     string      : enter path where opened workbook should be stored
2558 'optional   r   str_WindowTitle string      : enter window title for possible filedialog
2559 
2560 Function WorkbookOpen( _
2561                         ByRef wbk_Source As Workbook, _
2562                         Optional ByVal str_FileName As String = "", _
2563                         Optional ByVal str_DirPath As String = "", _
2564                         Optional ByRef str_WindowTitle = "" _
2565                                                                 ) As Boolean
2566                                                                 
2567 'WorkbookOpen: Open workbook
2568 'wbk_Source: returns reference on the opened workbook
2569 'str_Filename: text with file name > then path same as macro or full path of the file
2570 
2571     
2572     WorkbookOpen = False
2573     
2574     Dim strTempDate As String
2575     
2576     'CHECK PARAMETER IS OPEN EXIST AND IF LOCATION EXIST
2577 
2578     If str_DirPath = "" Then
2579     
2580         With CreateObject("Scripting.FileSystemObject")
2581     
2582             If .FileExists(str_FileName) Then
2583                 
2584                 str_DirPath = .getabsolutepathname(str_FileName)
2585                 str_FileName = .GetFileName(str_FileName)
2586                 
2587                 str_DirPath = Mid(str_DirPath, 1, Len(str_DirPath) - Len(str_FileName))
2588             Else
2589                 str_DirPath = ThisWorkbook.Path & "\"
2590             End If
2591         
2592         End With
2593         
2594     Else
2595         
2596         'Dir path fix
2597         If Not str_DirPath Like "*\" Then str_DirPath = str_DirPath & "\"
2598         'Dir path check
2599         If Not CreateObject("Scripting.FileSystemObject").FolderExists(str_DirPath) Then str_DirPath = ThisWorkbook.Path & "\"
2600     End If
2601       
2602     Call z_mChDirNet(str_DirPath)
2603       
2604     If str_WindowTitle = "" Then
2605         str_WindowTitle = "Please select file " & str_FileName
2606     End If
2607       
2608       
2609 'CHECK IF WORKBOOK ISN'T ALREADY OPEN
2610     If z_mWorkbookAlreadyOpen(wbk_Source, str_FileName) Then GoTo FILE_OPENED:
2611 
2612 
2613 SELECT_FILE:
2614       
2615     Const str_ExcelCompatibleFileFormats As String = "*.xls *.xlsx *.xlsb *.xlsm *.csv *.txt, *.*"
2616       
2617     If str_FileName = "" Then
2618         str_FileName = Application.GetOpenFilename(Title:=str_WindowTitle, FileFilter:=str_ExcelCompatibleFileFormats)
2619         
2620         Dim bool_FileTypeAccepted As Boolean
2621         
2622         bool_FileTypeAccepted = False
2623         If LCase(str_FileName) Like "*.xls" Then bool_FileTypeAccepted = True
2624         If LCase(str_FileName) Like "*.xlsx" Then bool_FileTypeAccepted = True
2625         If LCase(str_FileName) Like "*.xlsb" Then bool_FileTypeAccepted = True
2626         If LCase(str_FileName) Like "*.xlsm" Then bool_FileTypeAccepted = True
2627         If LCase(str_FileName) Like "*.csv" Then bool_FileTypeAccepted = True
2628         If LCase(str_FileName) Like "*.txt" Then bool_FileTypeAccepted = True
2629         
2630         
2631         If bool_FileTypeAccepted = False Then
2632              Select Case MsgBox("Wrong file type selected. Try again?", vbCritical + vbYesNo, "Wrong File type")
2633                 Case vbYes: str_FileName = "": GoTo SELECT_FILE
2634                 Case vbNo: Exit Function
2635             End Select
2636         End If
2637         
2638         'exit routine when file is empty
2639         If str_FileName = "False" Then
2640             Select Case MsgBox("File was not selected try again?", vbCritical + vbYesNo, "File Selection problem")
2641                 Case vbYes: str_FileName = "": GoTo SELECT_FILE
2642                 Case vbNo: Exit Function
2643             End Select
2644         End If
2645               
2646     Else
2647         
2648         'CHECK IF FILENAME EXIST
2649         If Not CreateObject("Scripting.FileSystemObject").FileExists(str_DirPath & str_FileName) Then
2650             Select Case MsgBox("File " & str_FileName & " was not found try again?", vbCritical + vbYesNo, "File not found")
2651                 Case vbYes: str_FileName = "": GoTo SELECT_FILE
2652                 Case vbNo: Exit Function
2653             End Select
2654         End If
2655     
2656         str_FileName = str_DirPath & str_FileName
2657     
2658     End If
2659 
2660 
2661 
2662 
2663 
2664     Set wbk_Source = Workbooks.Open(str_FileName)
2665     
2666 FILE_OPENED:
2667     
2668     WorkbookOpen = True
2669     
2670 End Function
2671 
2672 Private Function z_mWorkbookAlreadyOpen(ByRef wbk_Source As Workbook, Optional ByRef str_FileName As String = "") As Boolean
2673 
2674     z_mWorkbookAlreadyOpen = False
2675 
2676     If str_FileName = "" Then Exit Function
2677 
2678     'CHECK IF WORKBOOK ISN'T ALREADY OPEN
2679     On Error Resume Next
2680     Set wbk_Source = Workbooks(str_FileName)
2681     On Error GoTo 0
2682       
2683     z_mWorkbookAlreadyOpen = Not wbk_Source Is Nothing
2684 
2685 End Function
2686 
2687 
2688 
2689 Private Function z_mFilePathChecker( _
2690     ByRef str_FilePathOutput As String, _
2691     Optional ByRef str_FileName As String = "", _
2692     Optional ByVal str_DirPath As String = "", _
2693     Optional ByRef str_WindowTitle As String = "", _
2694     Optional ByVal str_ExcelCompatibleFileFormats As String = "*.*" _
2695         ) As Boolean
2696     
2697     z_mFilePathChecker = False
2698     
2699     Dim strTempDate As String
2700     
2701     'CHECK PARAMETER IS OPEN EXIST AND IF LOCATION EXIST
2702     
2703     If str_DirPath = "" Then
2704     
2705         
2706         With CreateObject("Scripting.FileSystemObject")
2707     
2708             If .FileExists(str_FileName) Then
2709                 
2710                 str_DirPath = .getabsolutepathname(str_FileName)
2711                 str_FileName = .GetFileName(str_FileName)
2712                 
2713                 str_DirPath = Mid(str_DirPath, 1, Len(str_DirPath) - Len(str_FileName))
2714             Else
2715                 str_DirPath = ThisWorkbook.Path & "\"
2716             End If
2717         
2718         End With
2719         
2720     Else
2721         
2722         'Dir path fix
2723         If Not str_DirPath Like "*\" Then str_DirPath = str_DirPath & "\"
2724         'Dir path check
2725         If Not CreateObject("Scripting.FileSystemObject").FolderExists(str_DirPath) Then str_DirPath = ThisWorkbook.Path & "\"
2726     End If
2727       
2728     Call z_mChDirNet(str_DirPath)
2729       
2730     If str_WindowTitle = "" Then
2731         str_WindowTitle = "Please select file " & str_FileName
2732     End If
2733  
2734 SELECT_FILE:
2735       
2736     'Const str_ExcelCompatibleFileFormats As String = "*.xls *.xlsx *.xlsb *.xlsm *.csv *.txt, *.*"
2737       
2738     Dim arr_CompatibleFormats
2739       
2740     arr_CompatibleFormats = Split(str_ExcelCompatibleFileFormats, " ")
2741       
2742     If str_FileName = "" Then
2743         str_FileName = Application.GetOpenFilename(Title:=str_WindowTitle, FileFilter:=str_ExcelCompatibleFileFormats & " ,*.*")
2744         
2745         Dim bool_FileTypeAccepted As Boolean
2746         Dim i_FormatCursor As Long
2747         
2748         bool_FileTypeAccepted = False
2749         
2750         'loop & check if file format fits to options
2751         For i_FormatCursor = LBound(arr_CompatibleFormats) To UBound(arr_CompatibleFormats)
2752             If LCase(str_FileName) Like LCase(arr_CompatibleFormats(i_FormatCursor)) Then bool_FileTypeAccepted = True
2753         Next
2754         
2755         If bool_FileTypeAccepted = False Then
2756              Select Case MsgBox("Wrong file type selected, posible formats: " & str_ExcelCompatibleFileFormats & vbCrLf & "Try again?", vbCritical + vbYesNo, "Wrong File type")
2757                 Case vbYes: str_FileName = "": GoTo SELECT_FILE
2758                 Case vbNo: Exit Function
2759             End Select
2760         End If
2761         
2762         'exit routine when file is empty
2763         If str_FileName = "False" Then
2764             Select Case MsgBox("File was not selected try again?", vbCritical + vbYesNo, "File Selection problem")
2765                 Case vbYes: str_FileName = "": GoTo SELECT_FILE
2766                 Case vbNo: Exit Function
2767             End Select
2768         End If
2769               
2770         str_FilePathOutput = str_FileName
2771               
2772     Else
2773         
2774         'CHECK IF FILENAME EXIST
2775         If Not CreateObject("Scripting.FileSystemObject").FileExists(str_DirPath & str_FileName) Then
2776             Select Case MsgBox("File " & str_FileName & " was not found try again?", vbCritical + vbYesNo, "File not found")
2777                 Case vbYes: str_FileName = "": GoTo SELECT_FILE
2778                 Case vbNo: Exit Function
2779             End Select
2780         End If
2781     
2782         str_FilePathOutput = str_DirPath & str_FileName
2783     
2784     End If
2785 
2786     z_mFilePathChecker = True
2787 
2788 End Function
2789 
2790 Function RangeColumnFilter( _
2791     rng_ToFilter As Range, _
2792     Optional ByVal arr_CriteriaInput As Variant, _
2793     Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
2794     Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
2795         )
2796 
2797 'recalculate column data
2798     Call z_mRangeRecalculate(rng_ToFilter)
2799 
2800 'check if filter list is not array
2801     Dim arr_Criteria
2802     arr_Criteria = z_mCovertToSimpleArray(arr_CriteriaInput)
2803         
2804     Dim rng_Cursor As Range
2805     Dim rng_ColumnsToHide As Range
2806     Dim lng_CriteriaCursor As Long
2807 
2808 'Loop for filter
2809     For Each rng_Cursor In rng_ToFilter
2810         
2811         Dim bool_Found As Boolean
2812         
2813         bool_Found = False
2814         
2815         For lng_CriteriaCursor = LBound(arr_Criteria) To UBound(arr_Criteria)
2816     
2817             If rng_Cursor Like arr_Criteria(lng_CriteriaCursor) Then
2818                  bool_Found = True
2819                  Exit For
2820             End If
2821 
2822         Next
2823 
2824         If InvertedAutoFilter = e_ShowOnlyCriteriaItems Then
2825             bool_Found = Not bool_Found
2826         End If
2827 
2828         If bool_Found Then
2829         
2830             If rng_ColumnsToHide Is Nothing Then
2831                 Set rng_ColumnsToHide = rng_Cursor
2832             Else
2833                 Set rng_ColumnsToHide = Union(rng_ColumnsToHide, rng_Cursor)
2834             End If
2835 
2836         End If
2837     
2838     Next
2839     
2840     If RemoveAutoFilter = e_ClearCurrentFilters Then
2841         rng_ToFilter.EntireColumn.Hidden = False
2842     End If
2843 
2844     If Not rng_ColumnsToHide Is Nothing Then
2845         rng_ColumnsToHide.EntireColumn.Hidden = True
2846     End If
2847 
2848 End Function
2849 
2850 
2851 Function WorkbookOpenLoop( _
2852     ByRef wbk_Source As Workbook, _
2853     Optional ByVal str_DirPath As String = "", _
2854     Optional ByVal arr_CriteriaInput As Variant, _
2855     Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems _
2856         ) As Boolean
2857     
2858     WorkbookOpenLoop = False
2859     
2860     Dim arr_Crititeria()
2861     
2862 'CHECK DATA INPUT
2863     If str_DirPath = "" Then str_DirPath = ThisWorkbook.Path & "\" 'no path defined
2864     If Not str_DirPath Like "*\" Then str_DirPath = str_DirPath & "\" 'fix missing slash
2865     If IsMissing(arr_CriteriaInput) Then
2866         ReDim arr_Crititeria(0)
2867         arr_Crititeria(0) = "*.xls*"    'set default mask
2868     Else
2869         arr_Crititeria = z_mCovertToSimpleArray(arr_CriteriaInput)
2870     End If
2871     
2872 'VARIABLES
2873 
2874     Dim cc_FilePaths As Collection
2875     Dim lng_ItemCursor As Long
2876     Dim str_FilePath As String
2877     
2878     If z_mKeyExists(cc_WorkbookPaths, str_DirPath) Then
2879     
2880         lng_ItemCursor = cc_WorkbookIndexes.Item(str_DirPath)
2881         'str_FilePath = cc_WorkbookPaths.Item(str_DirPath & str_FileMask)
2882 
2883         Set cc_FilePaths = cc_WorkbookPaths.Item(str_DirPath)
2884         
2885         If lng_ItemCursor > cc_FilePaths.Count Then 'everything looped exit function
2886             Set wbk_Source = Nothing
2887             Call cc_WorkbookIndexes.Remove(str_DirPath)  'reset
2888             Call cc_WorkbookIndexes.Add(1, str_DirPath)
2889             Exit Function
2890         End If
2891         
2892         str_FilePath = cc_FilePaths.Item(lng_ItemCursor)
2893     
2894         Call cc_WorkbookIndexes.Remove(str_DirPath)
2895         Call cc_WorkbookIndexes.Add(lng_ItemCursor + 1, str_DirPath)
2896     
2897     Else
2898             
2899         Dim file As Object
2900         
2901         Set cc_FilePaths = New Collection
2902 
2903         'loop all files
2904         With CreateObject("Scripting.FileSystemObject").GetFolder(str_DirPath)
2905     
2906             'loop all files
2907             For Each file In .Files
2908             
2909                 Dim str_FileName As String
2910                 
2911                 str_FileName = file.Name
2912             
2913                 Debug.Print str_FileName
2914             
2915                 Dim lng_Cursor As Long
2916                 Dim bool_Match As Boolean
2917                 
2918                 bool_Match = False
2919                 
2920                 For lng_Cursor = LBound(arr_Crititeria) To UBound(arr_Crititeria)
2921                     If UCase(str_FileName) Like UCase(arr_Crititeria(lng_Cursor)) Then
2922                         bool_Match = True
2923                         Exit For
2924                     End If
2925                 Next
2926                                
2927                 If InvertedAutoFilter = e_HideCriteriaItems Then
2928                     bool_Match = Not bool_Match
2929                 End If
2930                 
2931                 If bool_Match And (str_FileName Like "*.xls*" Or str_FileName Like "*.csv") Then
2932                     If str_FileName <> ThisWorkbook.Name Or Left(str_FileName, 2) <> "~$" Then 'protect open itslef
2933                         Call cc_FilePaths.Add(str_FileName)
2934                     End If
2935                 End If
2936 
2937             Next
2938     
2939         End With
2940         
2941        
2942         If cc_FilePaths.Count = 0 Then 'no files with criteria were found
2943             Set wbk_Source = Nothing
2944             Exit Function
2945         End If
2946         
2947         str_FilePath = cc_FilePaths.Item(1) 'set first item to this
2948         
2949         If cc_WorkbookPaths Is Nothing Then
2950             Set cc_WorkbookPaths = New Collection
2951             Set cc_WorkbookIndexes = New Collection
2952         End If
2953         
2954         Call cc_WorkbookPaths.Add(cc_FilePaths, str_DirPath)
2955         Call cc_WorkbookIndexes.Add(2, str_DirPath)
2956         
2957     End If
2958     
2959 
2960    'Load Workbook
2961     WorkbookOpenLoop = WorkbookOpen(wbk_Source, str_FilePath, str_DirPath)
2962     
2963 End Function
2964 
2965 
2966 Function WorkbookSave( _
2967     ByVal wbk_Source As Workbook, _
2968     Optional ByVal str_FileName As String = "", _
2969     Optional ByVal str_DirPath As String = "", _
2970     Optional dte_DateStampDay As Variant _
2971     )
2972     
2973     Dim wbk_Temp As Workbook
2974     Dim strTempDate$
2975     
2976     Set wbk_Temp = Workbooks(wbk_Source.Name)
2977 
2978     If Not IsMissing(dte_DateStampDay) And IsDate(dte_DateStampDay) Then
2979         strTempDate = "_" & Format(CDate(dte_DateStampDay), "yyyymmdd")
2980     Else
2981         strTempDate = ""
2982     End If
2983     
2984     If str_DirPath = "" Then
2985         str_DirPath = ThisWorkbook.Path & "\"
2986     End If
2987       
2988     ChDir str_DirPath
2989       
2990     If str_FileName = "" Then
2991        str_FileName = Application.GetSaveAsFilename(strTempDate & ".xlsm")
2992     Else
2993        str_FileName = str_DirPath & str_FileName & strTempDate & ".xlsm"
2994     End If
2995     
2996     Call wbk_Temp.SaveAs(str_FileName, 52)
2997     
2998 End Function
2999 
3000 'Workbook function to close workbook there is only one
3001 
3002 'Parameters
3003 'mandatory  r   wbk_Source              workbook    : close workbook in this parameter
3004 'optional   r   bool_SaveBeforeQuit     boolean     : predefined boolean to check if workbook should be automatically closed
3005 
3006 Function WorkbookClose( _
3007     Optional ByRef wbk_Source As Workbook, _
3008     Optional BeforeClose As e_ClosingAction = e_ClosingAction.e_DontSave _
3009     )
3010     
3011     If wbk_Source Is Nothing Then
3012         Set wbk_Source = ThisWorkbook
3013     End If
3014     
3015     Select Case BeforeClose
3016         Case e_ClosingAction.e_Save
3017             Call wbk_Source.Close(True)
3018         Case e_ClosingAction.e_DontSave
3019             'Application.DisplayAlerts = False
3020             Call wbk_Source.Close(False)
3021             'Application.DisplayAlerts = True
3022         Case e_ClosingAction.e_Delete
3023             
3024             'Application.DisplayAlerts = False
3025             Call wbk_Source.ChangeFileAccess(Mode:=xlReadOnly)
3026             Call Kill(wbk_Source.FullName)
3027             Call wbk_Source.Close(False)
3028             'Application.DisplayAlerts = True
3029             
3030     End Select
3031     
3032     Set wbk_Source = Nothing
3033     
3034 End Function
3035 
3036 'creates link between worksheet variable and the worksheet in the defined workbook
3037 'TBR ??
3038 'Parameters
3039 'mandatory  rw  sht_Link        worksheet   : returns shortcut on the opened worksheet
3040 'mandatory  r   wbk_Source      workbook    : enter shortcut to the opened workbook
3041 'optional   r   var_SheetId     variant     : enter sheet name or sheet order index if nothing is passed
3042 '                                              it automaticaly takes first sheet
3043 Function LinkSheetToShortcut( _
3044     ByRef sht_Link As Worksheet, _
3045     ByRef wbk_Source As Workbook, _
3046     Optional ByRef var_SheetId _
3047     ) As Boolean
3048 
3049     LinkSheetToShortcut = False
3050 
3051     On Error GoTo Err
3052 
3053     If IsMissing(var_SheetId) Then
3054         var_SheetId = 1
3055     End If
3056 
3057     Set sht_Link = wbk_Source.Sheets(var_SheetId)
3058     
3059     LinkSheetToShortcut = True
3060 
3061 Err:
3062 
3063     If Err.Number <> 0 Then
3064         Call MsgBox("Sheet called " & var_SheetId & " not found in the workbook " & wbk_Source.Name, vbCritical, "Error")
3065     End If
3066     
3067 End Function
3068 
3069 
3070 Function PivotRefresh( _
3071     ByRef pvt_Object As PivotTable _
3072         )
3073 
3074     pvt_Object.PivotCache.Refresh
3075     
3076 End Function
3077 
3078 Function PivotAutofilter( _
3079     ByRef pvt_Object As PivotTable, _
3080     Optional ByRef str_ColumnName As String = "", _
3081     Optional ByRef arr_CriteriaInput, _
3082     Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
3083     Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
3084     )
3085                             
3086 
3087     Dim arr_Criteria
3088     arr_Criteria = z_mCovertToSimpleArray(arr_CriteriaInput)
3089     
3090     Dim str_ValuePart As String
3091     
3092     If Not IsEmpty(arr_Criteria) Then
3093         str_ValuePart = " value" & IIf(UBound(arr_Criteria) > 0, "s: ", ": ") & arr_Criteria(0) & IIf(UBound(arr_Criteria) > 0, " ... ", "")
3094     End If
3095     
3096     Application.StatusBar = Mid("Filtering pivot table: " & pvt_Object.Name & " by field " & str_ColumnName & str_ValuePart, 1, 255)
3097 
3098     'Clear filters in pivot table
3099     If (str_ColumnName = "" Or RemoveAutoFilter = e_ClearCurrentFilters) And Not pvt_Object.PivotCache.OLAP Then
3100     
3101         Dim pvf_Cursor As PivotField
3102     
3103         For Each pvf_Cursor In pvt_Object.PivotFields
3104             pvf_Cursor.EnableMultiplePageItems = True
3105             pvf_Cursor.ClearAllFilters
3106         Next
3107     
3108         If RemoveAutoFilter <> e_ClearCurrentFilters Then Exit Function
3109     
3110     End If
3111 
3112     'Do pivot Filter
3113     With pvt_Object.PivotFields(str_ColumnName)
3114 
3115         If Not pvt_Object.PivotCache.OLAP Then
3116             .EnableMultiplePageItems = True
3117             .ClearAllFilters
3118         End If
3119 
3120         'just Clear pivot Filter
3121         If IsMissing(arr_CriteriaInput) Then Exit Function
3122 
3123         If InvertedAutoFilter Then
3124 
3125             Dim i& 'array index
3126             
3127             For i = LBound(arr_Criteria) To UBound(arr_Criteria)
3128                 On Error Resume Next
3129                     .PivotItems(CStr(arr_Criteria(i))).Visible = False
3130                 On Error GoTo 0
3131             Next
3132             
3133         Else
3134             If pvt_Object.PivotCache.OLAP Then
3135                 If .Orientation = xlPageField Then
3136                     .CurrentPageName = arr_Criteria(0)
3137                 Else
3138                     .VisibleItemsList = arr_Criteria
3139                 End If
3140             Else
3141             
3142                 Dim pvi_Cursor As PivotItem 'pivot item
3143                 Dim cc_HiddenItems As Collection
3144                 Call z_mFillCollection(arr_Criteria, cc_HiddenItems)
3145     
3146                 On Error GoTo err1004:
3147     
3148                 For Each pvi_Cursor In .PivotItems
3149                     pvi_Cursor.Visible = CLng(z_mKeyExists(cc_HiddenItems, pvi_Cursor.Name))
3150                 Next
3151     
3152             End If
3153 
3154     Exit Function
3155 
3156 err1004:
3157         If Err.Number = 1004 Then 'empty data error skip
3158             On Error GoTo 0
3159             Resume Next
3160         End If
3161         
3162         End If
3163     
3164     End With
3165     
3166 End Function
3167 
3168 Function PivotAutofilterDate( _
3169     ByRef pvt_Object As PivotTable, _
3170     ByRef str_ColumnName As String, _
3171     Optional ByRef arr_CriteriaInput As Variant, _
3172     Optional ByVal InvertedAutoFilter As e_FilterType = e_ShowOnlyCriteriaItems, _
3173     Optional ByVal RemoveAutoFilter As e_ResetFilter = e_LeaveCurrentFilters _
3174     )
3175                                    
3176     'Application.ScreenUpdating = False
3177                                 
3178     Dim i& 'array index
3179     
3180     'check if filter list is not array
3181     'If TypeName(arr_Criteria) = "Range" Then arr_Criteria = RangeToArray(arr_Criteria)
3182     Dim arr_Criteria
3183     arr_Criteria = z_mCovertToSimpleArray(arr_CriteriaInput, True)
3184     
3185     'Criteria Range To Date
3186 '    For i = LBound(arr_Criteria) To UBound(arr_Criteria)
3187 '       arr_Criteria(i) = CStr(Month(arr_Criteria(i)) & "/" & Day(arr_Criteria(i)) & "/" & Year(arr_Criteria(i)))
3188 '    Next
3189 
3190     With pvt_Object.PivotFields(str_ColumnName)
3191     
3192         .EnableMultiplePageItems = True
3193         .ClearAllFilters
3194 
3195         If InvertedAutoFilter Then
3196                        
3197             For i = LBound(arr_Criteria) To UBound(arr_Criteria)
3198                 .PivotItems(arr_Criteria(i)).Visible = False
3199             Next
3200             
3201         Else
3202             Dim pvi_Cursor As PivotItem 'pivot item
3203         
3204             Dim cc_HiddenItems As Collection
3205             Call z_mFillCollection(arr_Criteria, cc_HiddenItems)
3206         
3207             For Each pvi_Cursor In .PivotItems
3208                 With pvi_Cursor
3209                     .Visible = z_mKeyExists(cc_HiddenItems, .Name) 'z_mFoundInArray(arr_Criteria, pvi_Cursor.Name)
3210                 End With
3211             Next
3212 
3213         End If
3214     
3215     End With
3216     
3217     'Application.ScreenUpdating = True
3218 End Function
3219 
3220 Private Function z_mFoundInArray( _
3221     ByRef arr_Criteria, _
3222     ByRef var_Criteria _
3223     ) As Boolean
3224 
3225     z_mFoundInArray = True
3226 
3227 On Error GoTo NOT_FOUND
3228    Call WorksheetFunction.Match(var_Criteria, arr_Criteria, 0)
3229    
3230 NOT_FOUND:
3231     If Err.Number = 1004 Then
3232         z_mFoundInArray = False
3233         Resume Next
3234     End If
3235 
3236 End Function
3237 
3238 Function EmailCopyFromDraft( _
3239     ByRef obj_Email As Object, _
3240     ByRef str_DraftName As String, _
3241     Optional str_Subject As String, _
3242     Optional str_To As String, _
3243     Optional str_Cc As String, _
3244     Optional str_Bcc As String _
3245     ) As Boolean
3246 
3247     Dim obj_OutlookFolder As Object
3248     Dim obj_DraftEmail As Object
3249     
3250     Call z_mOutlookGetDefaultFolder(obj_OutlookFolder, e_Drafts)
3251     Call OutlookFindEmailInFolder(obj_DraftEmail, obj_OutlookFolder, str_DraftName)
3252 
3253 
3254     Set obj_Email = obj_DraftEmail.Copy
3255 
3256     With obj_Email
3257         If str_Subject <> "" Then
3258             .Subject = str_Subject
3259         Else
3260             .Subject = Mid(.Subject, 7, Len(.Subject))
3261         End If
3262         
3263         If str_To <> "" Then .To = str_To
3264         If str_Cc <> "" Then .cc = str_Cc
3265         If str_Bcc <> "" Then .Bcc = str_Bcc
3266     
3267         .Save
3268         .display
3269     
3270     End With
3271 
3272 End Function
3273 
3274 Function EmailTableFill( _
3275     ByRef obj_Email As Object, _
3276     ByRef tbl_Source As ListObject, _
3277     ByRef lng_Identifier As Long _
3278     )
3279 
3280 On Error GoTo Err
3281 
3282     Dim arr_QueryHeader()
3283     Dim arr_QueryResult() As String
3284     Dim lng_RowCounter As Long
3285     Dim lng_ColumnsCount As Long
3286     Dim rng_Cursor As Range
3287     Dim c_CopyCursor As Long
3288        
3289     arr_QueryHeader = tbl_Source.HeaderRowRange.Value
3290 
3291     lng_ColumnsCount = tbl_Source.HeaderRowRange.Count
3292 
3293     ReDim arr_QueryResult(1 To lng_ColumnsCount, 1 To 1)
3294 
3295     lng_RowCounter = 1
3296     
3297 'DATA ROW TO ARRAY
3298     'On Error GoTo EMPTY_TABLE:
3299 
3300     For Each rng_Cursor In tbl_Source.DataBodyRange.Resize(, 1)
3301        
3302         If rng_Cursor.EntireRow.Hidden = False Then
3303             For c_CopyCursor = 1 To lng_ColumnsCount
3304                 arr_QueryResult(c_CopyCursor, lng_RowCounter) = rng_Cursor.Offset(, c_CopyCursor - 1).Text
3305             Next
3306             
3307             ReDim Preserve arr_QueryResult(1 To lng_ColumnsCount, 1 To UBound(arr_QueryResult, 2) + 1)
3308             lng_RowCounter = lng_RowCounter + 1
3309         End If
3310 
3311     Next
3312     
3313     Dim bool_EmptySourceTable As Boolean
3314     
3315     If UBound(arr_QueryResult, 2) = 1 Then
3316         bool_EmptySourceTable = True
3317     Else
3318         ReDim Preserve arr_QueryResult(1 To lng_ColumnsCount, 1 To UBound(arr_QueryResult, 2) - 1)
3319     End If
3320     
3321     
3322 'TOTAL ROW EXIST
3323     If Not tbl_Source.TotalsRowRange Is Nothing Then
3324         Dim arr_TotalRowData
3325         ReDim arr_TotalRowData(1 To lng_ColumnsCount, 1 To 1)
3326 
3327         c_CopyCursor = 1
3328         For Each rng_Cursor In tbl_Source.TotalsRowRange
3329             arr_TotalRowData(c_CopyCursor, 1) = rng_Cursor.Text
3330             c_CopyCursor = c_CopyCursor + 1
3331         Next
3332     End If
3333     
3334    
3335 
3336 'OUTOLOOK PART
3337     Dim obj_OutlookFolder As Object
3338     Dim obj_NewEmail As Object
3339     Dim str_HtmlBody$
3340 
3341     With obj_Email
3342 
3343         str_HtmlBody = .htmlBody
3344         
3345         Dim str_ListLine$
3346         Dim str_ListFirstText$
3347         Dim str_BodyBegining$
3348         Dim str_BodyEnd$
3349         Dim lng_ListBeginning&
3350         Dim lng_ListEnd&
3351         Dim str_FinalList$
3352         Dim str_TempLine$
3353     
3354         'str_ListFirstText = "[" & tbl_Source.HeaderRowRange.Resize(1, 1).Value & "]" & lng_Identifier
3355     
3356         'find first item
3357         Dim rng_HeaderCursor As Range
3358         
3359         For Each rng_HeaderCursor In tbl_Source.HeaderRowRange
3360             str_ListFirstText = "[" & rng_HeaderCursor.Text & "]" & lng_Identifier
3361             
3362             If InStr(1, str_HtmlBody, str_ListFirstText) <> 0 Then
3363                 Exit For
3364             End If
3365     
3366         Next
3367     
3368         If str_ListFirstText = "" Then Exit Function
3369     
3370         lng_ListBeginning = InStrRev(str_HtmlBody, "<tr ", InStr(1, str_HtmlBody, str_ListFirstText))  'find end of paragraph text afte end first line tag
3371         
3372         
3373         lng_ListEnd = InStr(InStr(1, str_HtmlBody, str_ListFirstText), str_HtmlBody, "</tr>") + 5
3374 
3375         str_BodyBegining = Mid(str_HtmlBody, 1, lng_ListBeginning - 1)
3376         str_BodyEnd = Mid(str_HtmlBody, lng_ListEnd)
3377 
3378         str_ListLine = Mid(str_HtmlBody, lng_ListBeginning, lng_ListEnd - lng_ListBeginning)
3379 
3380 'If no data in table skip loop part this will remove whole row from table in email
3381         If bool_EmptySourceTable Then GoTo ENTERING_BODY
3382 
3383         Dim r_Cursor As Long
3384         Dim c_Cursor As Long
3385         
3386         For r_Cursor = 1 To UBound(arr_QueryResult, 2)
3387 
3388             For c_Cursor = LBound(arr_QueryHeader, 2) To UBound(arr_QueryHeader, 2)
3389 
3390                 If IsNull(arr_QueryResult(c_Cursor, r_Cursor)) Then arr_QueryResult(c_Cursor, r_Cursor) = ""
3391 
3392                 If c_Cursor = 1 Then
3393                     str_TempLine = Replace(str_ListLine, "[" & arr_QueryHeader(1, c_Cursor) & "]" & lng_Identifier, arr_QueryResult(c_Cursor, r_Cursor))
3394                 Else
3395                     str_TempLine = Replace(str_TempLine, "[" & arr_QueryHeader(1, c_Cursor) & "]" & lng_Identifier, arr_QueryResult(c_Cursor, r_Cursor))
3396                 End If
3397             Next
3398             str_FinalList = str_FinalList & str_TempLine
3399         Next
3400 
3401         If Not tbl_Source.TotalsRowRange Is Nothing Then
3402             For c_Cursor = LBound(arr_QueryHeader, 2) To UBound(arr_QueryHeader, 2)
3403                 str_BodyEnd = Replace(str_BodyEnd, "[" & arr_QueryHeader(1, c_Cursor) & "]Total" & lng_Identifier, arr_TotalRowData(c_Cursor, 1))
3404             Next
3405         End If
3406         
3407 ENTERING_BODY:
3408         
3409         str_HtmlBody = str_BodyBegining & str_FinalList & str_BodyEnd
3410 
3411         .htmlBody = str_HtmlBody
3412         
3413         .Save
3414     End With
3415 
3416 Exit Function
3417 Err:
3418 Debug.Assert False: Resume
3419 
3420 End Function
3421 
3422 Function EmailCreateNew( _
3423     ByRef obj_Email As Object, _
3424     Optional ByVal var_Body, _
3425     Optional ByVal str_Subject, _
3426     Optional ByVal var_To, _
3427     Optional ByVal var_Cc, _
3428     Optional ByVal var_Bcc _
3429     ) As Boolean
3430 
3431     Dim app_Outlook As Object 'Outlook.Application
3432 
3433     
3434     'Setup Outlook
3435     Set app_Outlook = GetObject(, "Outlook.Application") 'Set app_Outlook = Outlook.Application
3436     Set obj_Email = app_Outlook.CreateItem(0)
3437     
3438     Dim str_HtmlBody$
3439     
3440     With obj_Email
3441 
3442         On Error Resume Next
3443         If Not IsMissing(var_To) Then .To = Join(z_mCovertToSimpleArray(var_To), ";")
3444         If Not IsMissing(var_Cc) Then .cc = Join(z_mCovertToSimpleArray(var_Cc), ";")
3445         If Not IsMissing(var_Bcc) Then .Bcc = Join(z_mCovertToSimpleArray(var_Bcc), ";")
3446         On Error GoTo 0
3447         
3448         If Not IsMissing(str_Subject) Then .Subject = Join(z_mCovertToSimpleArray(str_Subject), "<br>")
3449 
3450         .display
3451         str_HtmlBody = .htmlBody
3452         
3453         'Split mailBody Mail Body on part before empty line and part after empty line
3454         Dim str_BodyStart$
3455         Dim str_BodyEnd$
3456         Dim lng_BodyText&
3457         
3458         Const str_EmptyLineText$ = "<p class=MsoNormal><o:p>&nbsp;</o:p></p>" 'empty line of the body
3459         
3460         lng_BodyText = InStr(1, str_HtmlBody, str_EmptyLineText)
3461     
3462         str_BodyStart = Mid(str_HtmlBody, 1, lng_BodyText - 1)
3463         str_BodyEnd = Mid(str_HtmlBody, lng_BodyText + Len(str_EmptyLineText), Len(str_HtmlBody))
3464 
3465         If Not IsMissing(var_Body) Then
3466             .htmlBody = str_BodyStart & "<p class=MsoNormal>" & Join(z_mCovertToSimpleArray(var_Body), "<br>") & "<br>" & "</o:p></p>" & str_BodyEnd
3467         End If
3468         
3469         .Save
3470         
3471     End With
3472     
3473     Call obj_Email.Recipients.ResolveAll
3474     
3475 End Function
3476 
3477 
3478 Function xDebugPrintTableLinker( _
3479                                 Optional wbk_Source As Workbook = Nothing _
3480                                 )
3481 
3482     If wbk_Source Is Nothing Then Set wbk_Source = ThisWorkbook
3483     
3484     Dim sht_Cursor As Worksheet
3485     Dim tbl_Cursor As ListObject
3486     Dim pvt_Cursor As PivotTable
3487     Dim name_Cursor As Name
3488     
3489     Dim arr_Dimensions_Tables()
3490     Dim arr_Initialization_Tables()
3491     
3492     Dim arr_Dimensions_Pivots()
3493     Dim arr_Initialization_Pivots()
3494     
3495     Dim arr_Dimensions_Ranges()
3496     Dim arr_Initialization_Ranges()
3497     
3498     ReDim arr_Dimensions_Tables(0)
3499     ReDim arr_Initialization_Tables(0)
3500     
3501     ReDim arr_Dimensions_Pivots(0)
3502     ReDim arr_Initialization_Pivots(0)
3503     
3504     ReDim arr_Dimensions_Ranges(0)
3505     ReDim arr_Initialization_Ranges(0)
3506     
3507     
3508     For Each name_Cursor In wbk_Source.Names
3509         If name_Cursor.Name Like "rng_*" Then
3510             
3511             arr_Dimensions_Ranges(UBound(arr_Dimensions_Ranges)) = "Dim " & name_Cursor.Name & " As Range"
3512             arr_Initialization_Ranges(UBound(arr_Initialization_Ranges)) = vbTab & "Call shtATk.RangeCreateLink(" & name_Cursor.Name & ",""" & name_Cursor.Name & """)"
3513             
3514     
3515             ReDim Preserve arr_Dimensions_Ranges(UBound(arr_Dimensions_Ranges) + 1)
3516             ReDim Preserve arr_Initialization_Ranges(UBound(arr_Initialization_Ranges) + 1)
3517     
3518         End If
3519     Next
3520     
3521     For Each sht_Cursor In wbk_Source.Worksheets
3522         For Each tbl_Cursor In sht_Cursor.ListObjects
3523         
3524             If tbl_Cursor.Name Like "t_*" Then
3525                 arr_Dimensions_Tables(UBound(arr_Dimensions_Tables)) = "Dim " & tbl_Cursor.Name & " As ListObject"
3526                 arr_Initialization_Tables(UBound(arr_Initialization_Tables)) = vbTab & "Call shtATk.TableCreateLink(" & tbl_Cursor.Name & ",""" & tbl_Cursor.Name & """)"
3527                 
3528                 ReDim Preserve arr_Dimensions_Tables(UBound(arr_Dimensions_Tables) + 1)
3529                 ReDim Preserve arr_Initialization_Tables(UBound(arr_Initialization_Tables) + 1)
3530             End If
3531         Next
3532         
3533         For Each pvt_Cursor In sht_Cursor.PivotTables
3534             
3535             If pvt_Cursor.Name Like "pvt_*" Then
3536                 arr_Dimensions_Pivots(UBound(arr_Dimensions_Pivots)) = "Dim " & pvt_Cursor.Name & " As PivotTable"
3537                 arr_Initialization_Pivots(UBound(arr_Initialization_Pivots)) = vbTab & "Call shtATk.PivotCreateLink(" & pvt_Cursor.Name & ",""" & pvt_Cursor.Name & """)"
3538                 
3539                 ReDim Preserve arr_Dimensions_Pivots(UBound(arr_Dimensions_Pivots) + 1)
3540                 ReDim Preserve arr_Initialization_Pivots(UBound(arr_Initialization_Pivots) + 1)
3541             End If
3542         Next
3543 
3544     Next
3545 
3546 'PRINTING RESULTS
3547 
3548     Debug.Print "'---- LINKER PART START --- Enter On the top of the routine module ----" & vbCrLf
3549     Debug.Print Join(arr_Dimensions_Ranges, vbCrLf)
3550     Debug.Print Join(arr_Dimensions_Tables, vbCrLf)
3551     Debug.Print Join(arr_Dimensions_Pivots, vbCrLf)
3552  
3553     Debug.Print "Function LinkWorkbookTables()" & vbCrLf
3554 
3555     If UBound(arr_Dimensions_Ranges) > 0 Then
3556         Debug.Print "'Global Ranges Part" & vbCrLf
3557         Debug.Print Join(arr_Initialization_Ranges, vbCrLf)
3558     End If
3559 
3560     If UBound(arr_Dimensions_Tables) > 0 Then
3561         Debug.Print "'Tables Part" & vbCrLf
3562         Debug.Print Join(arr_Initialization_Tables, vbCrLf)
3563     End If
3564     
3565     If UBound(arr_Dimensions_Pivots) > 0 Then
3566         Debug.Print "'Pivots Part" & vbCrLf
3567         Debug.Print Join(arr_Initialization_Pivots, vbCrLf)
3568     End If
3569     
3570     Debug.Print "End Function" & vbCrLf
3571     Debug.Print "'---- LINKER PART END ----"
3572 End Function
3573 
3574 Function TableCreateLink( _
3575     ByRef obj_Table As ListObject, _
3576     ByVal str_TableName As String, _
3577     Optional ByVal wbk_Source As Workbook _
3578     ) As Boolean
3579         
3580     If wbk_Source Is Nothing Then Set wbk_Source = ThisWorkbook
3581         
3582     Dim sht_Cursor As Worksheet
3583         
3584     On Error Resume Next
3585         
3586     For Each sht_Cursor In wbk_Source.Worksheets
3587     
3588        Set obj_Table = sht_Cursor.ListObjects(str_TableName)
3589  
3590     Next
3591     
3592     If obj_Table Is Nothing Then
3593         TableCreateLink = False
3594     Else
3595         TableCreateLink = True
3596     End If
3597 
3598 End Function
3599 
3600 Function PivotCreateLink( _
3601     ByRef obj_PivotTable As PivotTable, _
3602     ByVal str_TableName As String, _
3603     Optional ByVal wbk_Source As Workbook _
3604     ) As Boolean
3605         
3606     If wbk_Source Is Nothing Then Set wbk_Source = ThisWorkbook
3607         
3608     Dim sht_Cursor As Worksheet
3609         
3610     On Error Resume Next
3611         
3612     For Each sht_Cursor In wbk_Source.Worksheets
3613     
3614        Set obj_PivotTable = sht_Cursor.PivotTables(str_TableName)
3615  
3616     Next
3617     
3618     If obj_PivotTable Is Nothing Then
3619         PivotCreateLink = False
3620     Else
3621         PivotCreateLink = True
3622     End If
3623 
3624 End Function
3625 
3626 
3627 Function RangeCreateLink( _
3628     ByRef obj_Range As Range, _
3629     ByVal str_RangeName As String, _
3630     Optional ByVal wbk_Source As Workbook _
3631     ) As Boolean
3632         
3633     If wbk_Source Is Nothing Then Set wbk_Source = ThisWorkbook
3634         
3635     Dim sht_Cursor As Worksheet
3636         
3637     On Error Resume Next
3638 
3639     Dim arr_Address
3640 
3641     If CStr(wbk_Source.Names(str_RangeName).RefersTo) Like "*!*" Then
3642         arr_Address = Split(CStr(wbk_Source.Names(str_RangeName).RefersTo), "!")
3643     
3644         If arr_Address(0) Like "='* *'" Then
3645             arr_Address(0) = Mid(Left(arr_Address(0), Len(arr_Address(0)) - 1), 3)
3646         Else
3647             arr_Address(0) = Mid(arr_Address(0), 2)
3648         End If
3649         
3650         Set obj_Range = wbk_Source.Worksheets(arr_Address(0)).Range(arr_Address(1))
3651 
3652     Else
3653         'TDB Linked on TABLE Or formula
3654         
3655     
3656     End If
3657     
3658     
3659     RangeCreateLink = Not (obj_Range Is Nothing)
3660 
3661 End Function
3662 
3663 
3664 Function EmailCopyFromFile( _
3665     ByRef obj_Email As Object, _
3666     Optional ByVal str_FileName As String = "", _
3667     Optional ByVal str_DirPath As String = "", _
3668     Optional ByVal str_Subject, _
3669     Optional var_To, _
3670     Optional var_Cc, _
3671     Optional var_Bcc _
3672     ) As Boolean
3673 
3674   
3675     EmailCopyFromFile = False
3676     
3677     Dim strTempDate$
3678     Dim str_FinalPath As String
3679 
3680     If z_mFilePathChecker(str_FinalPath, str_FileName, str_DirPath, "Please select Outlook email file", "*.msg") = False Then Exit Function
3681 
3682     Dim app_Outlook As Object 'Outlook.Application
3683     
3684     'Setup Outlook
3685 
3686     Set app_Outlook = GetObject(, "Outlook.Application") 'Set app_Outlook = Outlook.Application
3687     
3688     Dim obj_DefaultFolder As Object
3689     Dim obj_EmailTemp As Object
3690     
3691     Call z_mOutlookGetDefaultFolder(obj_DefaultFolder, e_Drafts)
3692     
3693     Set obj_Email = app_Outlook.CreateItemFromTemplate(str_FinalPath, obj_DefaultFolder)
3694     EmailCopyFromFile = True
3695     obj_Email.Save
3696 
3697     'To correct language encoding  in neccerary create new copy of email
3698     Set obj_EmailTemp = obj_Email.Copy
3699     
3700     obj_Email.Delete
3701     
3702     Set obj_Email = obj_EmailTemp
3703     
3704     With obj_Email
3705     
3706         On Error Resume Next
3707             If Not IsMissing(var_To) Then .To = Join(z_mCovertToSimpleArray(var_To), ";")
3708             If Not IsMissing(var_Cc) Then .cc = Join(z_mCovertToSimpleArray(var_Cc), ";")
3709             If Not IsMissing(var_Bcc) Then .Bcc = Join(z_mCovertToSimpleArray(var_Bcc), ";")
3710             If Not IsMissing(str_Subject) Then .Subject = Join(z_mCovertToSimpleArray(str_Subject), ";")
3711         On Error GoTo 0
3712         
3713         .display
3714         .Save
3715         
3716     End With
3717     
3718     Call obj_Email.Recipients.ResolveAll
3719     
3720     EmailCopyFromFile = True
3721     
3722 End Function
3723 
3724 Function EmailSend( _
3725         ByRef obj_Email As Object _
3726     )
3727 
3728     'Get Focus for Email Window
3729     obj_Email.display
3730     
3731     'Wait 1 Second
3732     Application.Wait (Now + TimeValue("0:00:01"))
3733     
3734     'Press CTRL+Enter to sent shortcut
3735     SendKeys "^{ENTER}"
3736 
3737 End Function
3738         
3739 
3740 
3741 
3742 Function EmailReplaceText( _
3743     ByRef obj_Email As Object, _
3744     ByVal var_TextToReplace As Variant, _
3745     ByVal var_ReplaceWith As Variant _
3746     )
3747     
3748     Dim str_HtmlBody$
3749     Dim i_TextCursor As Long
3750 
3751     Call z_mCovertToSimpleArray(var_TextToReplace)
3752     Call z_mCovertToSimpleArray(var_ReplaceWith)
3753 
3754     If UBound(var_ReplaceWith) <> UBound(var_TextToReplace) Then Exit Function
3755 
3756     With obj_Email
3757     
3758         For i_TextCursor = LBound(var_ReplaceWith) To UBound(var_ReplaceWith)
3759             .htmlBody = Replace(.htmlBody, CStr(var_TextToReplace(i_TextCursor)), CStr(var_ReplaceWith(i_TextCursor)))
3760         Next
3761         
3762         .Save
3763         .display
3764     End With
3765 
3766 End Function
3767 
3768 
3769 Function EmailAttachWorkbook( _
3770     ByRef obj_Email As Object, _
3771     Optional ByRef wbk_Source As Workbook, _
3772     Optional ByRef str_WorkbookName As String _
3773     ) As Boolean
3774   
3775     'Dim obj_Email As Object
3776 
3777     If wbk_Source Is Nothing Then Set wbk_Source = ThisWorkbook
3778 
3779     wbk_Source.Save
3780 
3781 'Create Temporary file neccecary if different file name TDB
3782     
3783 
3784     With obj_Email
3785         .Attachments.Add wbk_Source.FullName
3786         .Save
3787     End With
3788      
3789 End Function
3790 
3791 Function EmailAttachFile( _
3792     ByRef obj_Email As Object, _
3793     Optional ByRef str_DirPath As String, _
3794     Optional ByRef str_FileName As String, _
3795     Optional str_WindowTitle As String _
3796     ) As Boolean
3797   
3798     EmailAttachFile = False
3799     
3800     Dim strTempDate$
3801     
3802     'CHECK FILEPATH EXIST
3803     
3804     If str_DirPath = "" Then
3805         str_DirPath = ThisWorkbook.Path & "\"
3806     End If
3807       
3808     ChDir str_DirPath
3809       
3810     If str_WindowTitle = "" Then
3811         str_WindowTitle = "Please select file " & str_FileName
3812     End If
3813       
3814 SELECT_FILE:
3815       
3816     If str_FileName = "" Then
3817        str_FileName = Application.GetOpenFilename(Title:=str_WindowTitle)
3818     Else
3819         If Not str_DirPath Like "*\" Then str_DirPath = str_DirPath & "\"
3820         
3821         'CHECK IF FILENAME EXIST
3822         
3823         str_FileName = str_DirPath & str_FileName
3824     End If
3825     
3826     'exit routine when file is empty
3827     If str_FileName = "False" Then
3828         Select Case MsgBox("File was not selected try again?", vbCritical + vbYesNo, "File Selection problem")
3829             Case vbYes: str_FileName = "": GoTo SELECT_FILE
3830             Case vbNo: Exit Function
3831         End Select
3832     End If
3833     
3834     
3835     With obj_Email
3836         .Attachments.Add str_FileName
3837         .Save
3838     End With
3839      
3840     EmailAttachFile = True
3841      
3842 End Function
3843 
3844 
3845 Function EmailSaveAttachment( _
3846     ByRef obj_Email As Object, _
3847     Optional ByVal str_SavePath As Variant, _
3848     Optional ByVal str_AttachmentFileMask As Variant, _
3849     Optional ByVal str_FileName As Variant, _
3850     Optional ByVal lng_NameAction As e_FileNameAction = e_Prefix _
3851     )
3852 
3853 
3854     If obj_Email.Attachments.Count = 0 Then Exit Function
3855 
3856     If IsMissing(str_SavePath) Then str_SavePath = ThisWorkbook.Path
3857 
3858     Dim objAtt As Object
3859     Dim str_OriginalName As String
3860    
3861     
3862     For Each objAtt In obj_Email.Attachments
3863     
3864         Dim str_AttFilename As String
3865     
3866         str_AttFilename = objAtt.FileName
3867         str_OriginalName = objAtt.DisplayName
3868     
3869         If Not IsMissing(str_AttachmentFileMask) Then
3870             If Not str_AttFilename Like str_AttachmentFileMask Then
3871                 GoTo NEXT_ATTACHEMENT
3872             End If
3873         End If
3874     
3875     
3876         If Not IsMissing(str_FileName) Then
3877             Select Case lng_NameAction
3878                 Case e_Prefix: str_OriginalName = str_FileName + str_AttFilename
3879                 Case e_Suffix:  str_OriginalName = str_OriginalName + str_FileName + Split(str_AttFilename, ".")(1)
3880                 Case e_Replace: str_OriginalName = Replace(str_AttFilename, str_OriginalName, str_FileName)
3881             End Select
3882         End If
3883     
3884         objAtt.SaveAsFile str_SavePath & "\" & str_OriginalName
3885         
3886 NEXT_ATTACHEMENT:
3887         Set objAtt = Nothing
3888     Next
3889 
3890 End Function
3891 
3892 
3893 Private Function z_mOutlookGetDefaultFolder( _
3894     ByRef obj_OutlookFolder As Object, _
3895     ByVal DefaultFolderType As OutlookFolders _
3896     ) As Boolean
3897     
3898     Dim app_Outlook As Object 'Outlook.Application
3899     
3900     'Setup Outlook
3901     Set app_Outlook = GetObject(, "Outlook.Application") 'Set app_Outlook = Outlook.Application
3902     Set obj_OutlookFolder = app_Outlook.GetNamespace("MAPI").GetDefaultFolder(16) '16 = olFolderDrafts
3903     
3904 End Function
3905 
3906 Public Function EmailFlag(ByRef obj_Email As Object, Optional ByVal lng_Flag As e_OutlookFlag = e_Complete)
3907 
3908     obj_Email.flagStatus = lng_Flag
3909     obj_Email.Save
3910 
3911 End Function
3912 
3913 
3914 Private Function z_mEmailFindInOutlookFolder( _
3915     ByRef obj_Email As Object, _
3916     ByRef obj_Folder As Object, _
3917     ByRef str_Subject$ _
3918     ) As Boolean
3919 
3920     Dim lng_MailsCount&
3921     Dim lng_MailCursor&
3922     
3923     Dim bool_MailFound As Boolean
3924     'Find Draft Email
3925     
3926     OutlookFindEmailInFolder = False
3927     
3928     lng_MailsCount = obj_Folder.items.Count
3929     
3930     lng_MailCursor = 1
3931     Do Until lng_MailCursor > lng_MailsCount
3932       
3933         If obj_Folder.items.Item(lng_MailCursor).Subject Like str_Subject Then
3934             bool_MailFound = True
3935             Exit Do
3936         End If
3937         
3938         lng_MailCursor = lng_MailCursor + 1
3939     Loop
3940     
3941     If bool_MailFound Then
3942         OutlookFindEmailInFolder = True
3943         Set obj_Email = obj_Folder.items.Item(lng_MailCursor)
3944     End If
3945 
3946 End Function
3947 
3948 Private Function z_mFillCollection( _
3949     ByRef arr_List, _
3950     ByRef cc_Container As Collection _
3951     )
3952 
3953     Set cc_Container = New Collection
3954     
3955     Dim i&
3956     
3957     For i = LBound(arr_List) To UBound(arr_List)
3958        Call cc_Container.Add(arr_List(i), CStr(arr_List(i)))
3959     Next
3960     
3961 End Function
3962 
3963 Private Function z_mKeyExists( _
3964     ByRef cc_Container As Collection, _
3965     ByVal strKey As String _
3966     ) As Boolean
3967     On Error GoTo Exists_Err
3968     'Dim strKey$: strKey = CStr(varKey)
3969     Dim lngType&: lngType = VarType(cc_Container.Item(strKey))
3970     z_mKeyExists = True
3971 Exit_Function:
3972     lngType = 0
3973     Exit Function
3974 Exists_Err:
3975     If Err.Number = 9 Or Err.Number = 5 Then z_mKeyExists = False
3976 End Function
3977 
3978 Function TextToColumnsDelimeted( _
3979     ByVal rngColumns As Range, _
3980     Optional ByVal arr_FieldType As Variant, _
3981     Optional ByRef str_Delimeter$ = "", _
3982     Optional ByRef TextQualifier As XlTextQualifier, _
3983     Optional str_DecimalSeparator$ = "", _
3984     Optional str_ThousandSeparator$ = "" _
3985     )
3986     Dim arr_FieldTypesResult
3987 
3988     Dim bool_Semicolon As Boolean
3989     Dim bool_Comma As Boolean
3990     Dim bool_Space As Boolean
3991     Dim bool_Tab As Boolean
3992     Dim bool_Other As Boolean
3993     
3994     Dim str_OtherChar As String
3995 
3996     If IsMissing(arr_FieldType) Then
3997         arr_FieldTypesResult = Array(1, xlGeneralFormat)
3998     Else
3999         'prepare column data type
4000         If UBound(arr_FieldType) = 0 Then
4001             arr_FieldTypesResult = Array(1, arr_FieldType(0))
4002         Else
4003             ReDim arr_FieldTypesResult(1 To UBound(arr_FieldType) + 1, 9)
4004             Dim i_FieldCursor&
4005             
4006             For i_FieldCursor = 0 To UBound(arr_FieldType)
4007                 arr_FieldTypesResult(i_FieldCursor) = Array(i_FieldCursor + 1, arr_FieldType(i_FieldCursor))
4008             Next
4009             
4010         End If
4011     End If
4012     
4013 
4014      Select Case str_Delimeter
4015          Case ""
4016          Case "Semicolon": bool_Semicolon = True
4017          Case "Comma": bool_Comma = True
4018          Case "Space": bool_Space = True
4019          Case "Tab": bool_Tab = True
4020          Case Else
4021              bool_Other = True
4022              str_OtherChar = str_Delimeter
4023      End Select
4024 
4025     Dim rng_Cursor As Range
4026    
4027     For Each rng_Cursor In rngColumns.Resize(1)
4028 
4029         rng_Cursor.EntireColumn.TextToColumns _
4030             Destination:=rng_Cursor.EntireColumn, _
4031             DataType:=xlDelimited, _
4032             TextQualifier:=xlDoubleQuote, _
4033             ConsecutiveDelimiter:=False, _
4034             Tab:=bool_Tab, _
4035             Semicolon:=bool_Semicolon, _
4036             Comma:=bool_Comma, _
4037             Space:=bool_Space, _
4038             Other:=bool_Other, _
4039             OtherChar:=str_OtherChar, _
4040             FieldInfo:=arr_FieldTypesResult, _
4041             TrailingMinusNumbers:=True
4042  
4043     Next
4044 
4045 End Function
4046 
4047 Function TableCreateFromRange( _
4048     ByRef tbl_NewTable As ListObject, _
4049     ByVal rng_SourceRange As Range, _
4050     Optional ByVal lng_HeaderRow As Long = 1, _
4051     Optional ByVal str_TableName As String _
4052     )
4053 
4054     If lng_HeaderRow < 1 Then Exit Function
4055     
4056     If lng_HeaderRow > 1 Then
4057         Set rng_SourceRange = rng_SourceRange.CurrentRegion.Offset(lng_HeaderRow - 1).Resize(rng_SourceRange.Rows.Count - lng_HeaderRow)
4058     Else
4059         Set rng_SourceRange = rng_SourceRange.CurrentRegion
4060     End If
4061 
4062     'Application.ScreenUpdating = False
4063     
4064       
4065     'Remove Autofilter
4066     On Error Resume Next
4067     rng_SourceRange.Worksheet.AutoFilterMode = False
4068     On Error GoTo 0
4069     
4070     'Recalculate before add
4071     Call z_mRangeRecalculate(rng_SourceRange)
4072     
4073     'Create New Table
4074     Set tbl_NewTable = rng_SourceRange.Worksheet.ListObjects.Add(xlSrcRange, rng_SourceRange, , xlYes)
4075     
4076     'Clear TableStyle
4077     tbl_NewTable.TableStyle = ""
4078     
4079     'Name Table if there is name Set
4080     If str_TableName <> "" Then tbl_NewTable.Name = str_TableName
4081       
4082     'Application.ScreenUpdating = True
4083       
4084 End Function
4085 
4086 Function PivotDataAppendToTable( _
4087                                 ByVal pvt_Copy As PivotTable, _
4088                                 ByVal tbl_PasteAppend As ListObject, _
4089                                 Optional ByVal arr_HeaderMask As Variant _
4090                                 )
4091 
4092     Application.StatusBar = "Appending PivotDataTable " & pvt_Copy.Name & " to " & tbl_PasteAppend.Name
4093     
4094     pvt_Copy.PivotCache.Refresh
4095 
4096     Dim rng_DataRange As Range
4097    
4098     Set rng_DataRange = Intersect(pvt_Copy.TableRange1, pvt_Copy.DataBodyRange.EntireRow)
4099     Set rng_DataRange = rng_DataRange.Resize(rng_DataRange.Rows.Count - Abs(CLng(pvt_Copy.RowGrand)), rng_DataRange.Columns.Count - Abs(CLng(pvt_Copy.ColumnGrand)))
4100 
4101     Dim lng_CalcActions As Long
4102     
4103     lng_CalcActions = Application.Calculation
4104     Application.Calculation = xlCalculationManual
4105 
4106 'CALCULATE ROWS TO COPY
4107     On Error GoTo Err
4108 
4109     Dim arr_VisibleRows()
4110     ReDim arr_VisibleRows(0)
4111   
4112 'PREPARE COPY
4113     Dim rng_Cursor As Range
4114     Dim arr_Copy
4115     
4116     Dim lng_RowCounter As Long
4117     Dim lng_CopyRowsCount&
4118     
4119     lng_RowCounter = 2 'second row data start 1 reserved for header
4120 
4121     For Each rng_Cursor In rng_DataRange.Resize(, 1)
4122             
4123         arr_VisibleRows(UBound(arr_VisibleRows)) = lng_RowCounter
4124         ReDim Preserve arr_VisibleRows(UBound(arr_VisibleRows) + 1)
4125 
4126         lng_RowCounter = lng_RowCounter + 1
4127     Next
4128     
4129     ReDim Preserve arr_VisibleRows(UBound(arr_VisibleRows) - 1)
4130 
4131     arr_Copy = rng_DataRange.Resize(rng_DataRange.Rows.Count + 1).Offset(-1).Value2 'copy data with header
4132 
4133     If UBound(arr_VisibleRows) = 0 Then GoTo Exit_Function: ' nothing to append
4134     
4135     Dim lng_ColumnCounter As Long
4136     
4137     lng_ColumnCounter = 1
4138 
4139  
4140     For Each rng_Cursor In rng_DataRange.Resize(1).Offset(-1)
4141         arr_Copy(1, lng_ColumnCounter) = rng_Cursor.Text
4142     
4143         lng_ColumnCounter = lng_ColumnCounter + 1
4144     
4145     Next
4146 
4147 'PREPARE PASTE
4148     Dim arr_Paste As Variant
4149     arr_Paste = tbl_PasteAppend.Range.Formula
4150     
4151     Dim arr_HeaderRelation()
4152     Dim arr_HeaderArrayFormula()
4153     
4154     Dim c_AppendCursor As Long
4155     Dim c_CopyCursor As Long
4156     
4157     Dim lng_ColumnInCopy As Long
4158     
4159     ReDim arr_HeaderRelation(1 To UBound(arr_Paste, 2))
4160     ReDim arr_HeaderArrayFormula(1 To UBound(arr_Paste, 2))
4161     
4162     
4163 'IF THERE IS DATA MASK CONVERT TABLE HEADER TO IT
4164     If Not IsMissing(arr_HeaderMask) Then
4165         
4166         If TypeName(arr_HeaderMask) = "Range" Then
4167             
4168             c_AppendCursor = 1
4169             
4170             arr_HeaderMask.Calculate
4171             
4172             For Each rng_Cursor In arr_HeaderMask
4173                 arr_Paste(1, c_AppendCursor) = rng_Cursor.Text
4174                 c_AppendCursor = c_AppendCursor + 1
4175             Next
4176         Else
4177             Call z_mCovertToSimpleArray(arr_HeaderMask)
4178         
4179             For c_AppendCursor = LBound(arr_Paste, 2) To UBound(arr_Paste, 2)
4180                 arr_Paste(1, c_AppendCursor) = arr_HeaderMask(c_AppendCursor - 1)
4181             Next
4182 
4183         End If
4184     
4185     End If
4186     
4187     
4188 'MAP HEADER
4189     For c_AppendCursor = LBound(arr_Paste, 2) To UBound(arr_Paste, 2)
4190         
4191         lng_ColumnInCopy = -1
4192         
4193     'SEARCHING LOOP
4194         For c_CopyCursor = LBound(arr_Copy, 2) To UBound(arr_Copy, 2)
4195             If arr_Paste(1, c_AppendCursor) = arr_Copy(1, c_CopyCursor) Then
4196                 lng_ColumnInCopy = c_CopyCursor
4197                 Exit For 'Found
4198             End If
4199         Next
4200     
4201         arr_HeaderArrayFormula(c_AppendCursor) = tbl_PasteAppend.HeaderRowRange.Resize(1, 1).Offset(1, c_AppendCursor - 1).HasArray
4202         arr_HeaderRelation(c_AppendCursor) = lng_ColumnInCopy
4203     
4204     Next
4205     
4206     Dim lng_AppendRows As Long
4207     lng_AppendRows = UBound(arr_Paste)
4208     
4209     'traspose array
4210     Dim arr_Append()
4211     ReDim arr_Append(1 To UBound(arr_VisibleRows) + 1, 1 To UBound(arr_Paste, 2))
4212 
4213     For c_AppendCursor = LBound(arr_HeaderRelation) To UBound(arr_HeaderRelation)
4214         
4215         If arr_HeaderRelation(c_AppendCursor) <> "-1" Then
4216             
4217             For c_CopyCursor = LBound(arr_VisibleRows) To UBound(arr_VisibleRows)
4218                 arr_Append(c_CopyCursor + 1, c_AppendCursor) = arr_Copy(arr_VisibleRows(c_CopyCursor), arr_HeaderRelation(c_AppendCursor))
4219             Next
4220         Else
4221             
4222             If arr_Paste(2, c_AppendCursor) Like "=*" Then 'extend formula
4223             
4224                 For c_CopyCursor = LBound(arr_VisibleRows) To UBound(arr_VisibleRows)
4225                     arr_Append(c_CopyCursor + 1, c_AppendCursor) = arr_Paste(2, c_AppendCursor)
4226                 Next
4227             
4228             End If
4229 
4230         End If
4231     
4232     Next
4233 
4234 
4235     Dim lng_PasteOffset As Long
4236     Dim lng_PasteResize As Long
4237 
4238     If tbl_PasteAppend.Range.Rows.Count = 2 Then
4239 
4240         If tbl_PasteAppend.HeaderRowRange.Offset(1).SpecialCells(xlCellTypeConstants).Count = 0 Then
4241             lng_PasteResize = 1
4242         Else
4243             lng_PasteResize = 0
4244         End If
4245     End If
4246 
4247     'End With
4248     
4249     
4250     Dim rng_AppendArea As Range
4251     
4252     Set rng_AppendArea = tbl_PasteAppend.Range.Offset(tbl_PasteAppend.Range.Rows.Count - lng_PasteResize).Resize(UBound(arr_Append))
4253     
4254 'RESIZE PASTE TABLE
4255     Call tbl_PasteAppend.Resize(tbl_PasteAppend.Range.Resize((UBound(arr_Paste) - lng_PasteResize) + (UBound(arr_VisibleRows) + 1)))
4256     
4257     
4258     rng_AppendArea = arr_Append
4259     
4260     
4261 'CHECK IF THERE WAS ANY ARRAY FORMULAS
4262     For c_AppendCursor = LBound(arr_HeaderArrayFormula) To UBound(arr_HeaderArrayFormula)
4263         If arr_HeaderArrayFormula(c_AppendCursor) And arr_HeaderRelation(c_AppendCursor) = -1 Then
4264             rng_AppendArea.Resize(1, 1).Offset(, c_AppendCursor - 1).FormulaArray = arr_Paste(2, c_AppendCursor)
4265             rng_AppendArea.Resize(, 1).Offset(, c_AppendCursor - 1).FillDown
4266         End If
4267     Next
4268     
4269     rng_AppendArea.Calculate
4270 
4271     DoEvents
4272     DoEvents
4273 
4274 Exit_Function:
4275 
4276     Application.StatusBar = False
4277     Exit Function
4278 Err:
4279   
4280     Debug.Print Err.Number & Err.Description
4281     Select Case Err.Number
4282         Case 1004: If Err.Description = "No cells were found." Then Resume Next
4283         Case 0
4284     End Select
4285   'Resume
4286     
4287 End Function
4288 
4289 Public Function xLinkExcelObjects()
4290 
4291     Dim CodePan As Object
4292     
4293     Call zSelectCodePan(CodePan, "mod_AtkBindings")
4294 
4295     Dim FindWhat As String
4296     Dim SL As Long ' start line
4297     Dim EL As Long ' end line
4298 
4299     With CodePan
4300         SL = 1
4301         EL = .CountOfLines
4302     End With
4303         
4304 'LOAD ALL VARIABLES IN WORKBOOK
4305 
4306     Dim cc_RangeDeclarations As Collection
4307     Dim cc_TableDeclarations As Collection
4308     Dim cc_PivotDeclarations As Collection
4309     
4310     Dim cc_RangeInitiation As Collection
4311     Dim cc_TableInitiation As Collection
4312     Dim cc_PivotInitiation As Collection
4313 
4314     Set cc_RangeDeclarations = New Collection
4315     Set cc_TableDeclarations = New Collection
4316     Set cc_PivotDeclarations = New Collection
4317     
4318     Set cc_RangeInitiation = New Collection
4319     Set cc_TableInitiation = New Collection
4320     Set cc_PivotInitiation = New Collection
4321     
4322     Dim str_CodeLine As String
4323     Dim name_Cursor As Name
4324     Dim sht_Cursor As Worksheet
4325     Dim tbl_Cursor As ListObject
4326     Dim pvt_Cursor As PivotTable
4327      
4328     For Each name_Cursor In ThisWorkbook.Names
4329         If name_Cursor.Name Like "rng_*" Then
4330             
4331             str_CodeLine = Replace("Public XNAME As Range", "XNAME", name_Cursor.Name)
4332             Call cc_RangeDeclarations.Add(str_CodeLine, str_CodeLine)
4333             
4334             str_CodeLine = Replace("Call shtATk.RangeCreateLink(XNAME, ""XNAME"")", "XNAME", name_Cursor.Name)
4335 
4336             Call cc_RangeInitiation.Add(str_CodeLine, str_CodeLine)
4337           
4338         End If
4339     Next
4340     
4341     For Each sht_Cursor In ThisWorkbook.Worksheets
4342         For Each tbl_Cursor In sht_Cursor.ListObjects
4343         
4344             If tbl_Cursor.Name Like "t_*" Then
4345             
4346                 str_CodeLine = Replace("Public XNAME As ListObject", "XNAME", tbl_Cursor.Name)
4347                 Call cc_TableDeclarations.Add(str_CodeLine, str_CodeLine)
4348                 
4349                 str_CodeLine = Replace("Call shtATk.TableCreateLink(XNAME, ""XNAME"")", "XNAME", tbl_Cursor.Name)
4350                 Call cc_TableInitiation.Add(str_CodeLine, str_CodeLine)
4351             
4352             End If
4353         Next
4354         
4355         For Each pvt_Cursor In sht_Cursor.PivotTables
4356             
4357             If pvt_Cursor.Name Like "pvt_*" Then
4358             
4359                 str_CodeLine = Replace("Public XNAME As PivotTable", "XNAME", pvt_Cursor.Name)
4360                 Call cc_PivotDeclarations.Add(str_CodeLine, str_CodeLine)
4361                 
4362                 str_CodeLine = Replace("Call shtATk.PivotCreateLink(XNAME, ""XNAME"")", "XNAME", pvt_Cursor.Name)
4363                 Call cc_PivotInitiation.Add(str_CodeLine, str_CodeLine)
4364             
4365             End If
4366         Next
4367     Next
4368 
4369 'CHECK IF EXIST LINKER FUNCTION IF NOT CREATE IT
4370     Dim lng_LinkerFunctionRow As Long
4371         
4372     With CodePan
4373         
4374         SL = 1 '.CountOfDeclarationLines ' 1 find first
4375         Do Until .lines(SL, 1) Like "*Function *(*)" Or .lines(SL, 1) Like "*Sub *(*)" Or SL > .CountOfLines
4376             Call z_mPP(SL)
4377         Loop
4378             
4379         If SL = 1 Then SL = 2
4380             
4381         If Not z_mLinkExcelObjects_Codefind(CodePan, "Function LinkWorkbookTables()", SL) Then
4382             Call .InsertLines(SL - 1, Join(Array("", "Function LinkWorkbookTables()", "", "End Function", ""), vbCr))
4383         End If
4384  
4385     End With
4386  
4387  
4388 'DEFINE LINKER ROW
4389     Call z_mLinkExcelObjects_Codefind(CodePan, "Function LinkWorkbookTables()", lng_LinkerFunctionRow)
4390 
4391 'CHECK AND REMOVE NOT WORKING LINKER LINES
4392     Dim obj_Dummy As Object
4393 
4394     With CodePan
4395         SL = 1 'find first
4396         Do Until .lines(SL, 1) Like "*End Function*"
4397             If .lines(SL, 1) Like "*Call shtATk.RangeCreateLink*" Or .lines(SL, 1) Like "*Call shtATk.TableCreateLink*" Or .lines(SL, 1) Like "*Call shtATk.PivotCreateLink*" Then
4398                 Call CallByName(shtATk, Split(Split(.lines(SL, 1), ".")(1), "(")(0), VbMethod, obj_Dummy, CStr(Split(.lines(SL, 1), """")(1)))
4399                  
4400                 If obj_Dummy Is Nothing Then
4401                     Dim str_ItemName As String
4402             
4403                     str_ItemName = CStr(Split(.lines(SL, 1), """")(1))
4404                     
4405                     Debug.Print str_ItemName & " not found will be removed"
4406                     
4407                 'REMOVE INITIATION LINE
4408                     Call .DeleteLines(SL)
4409                     SL = SL - 1 'decrease counter to avoid skipping in loop
4410                     
4411                 'REMOVE DELCLARATION LINE IF EXIST
4412                     SL = 1
4413                     If z_mLinkExcelObjects_Codefind(CodePan, Replace("Public XNAME As", "XNAME", str_ItemName), SL) Then
4414                         Call .DeleteLines(SL)
4415                         SL = SL - 1 'decrease counter to avoid skipping in loop
4416                     End If
4417                    
4418                 Else
4419                     Set obj_Dummy = Nothing
4420                 End If
4421             End If
4422             Call z_mPP(SL)
4423         Loop
4424     End With
4425 
4426 
4427     Dim str_CodePart As String
4428     Dim lng_Row As Long
4429         
4430 'RANGES
4431     For lng_Row = 1 To cc_RangeDeclarations.Count
4432         If Not z_mLinkExcelObjects_Codefind(CodePan, cc_RangeDeclarations.Item(lng_Row)) Then
4433             Debug.Print "Added Link for " & Split(cc_RangeDeclarations.Item(lng_Row), " ")(1)
4434         End If
4435     
4436         str_CodePart = str_CodePart & cc_RangeDeclarations.Item(lng_Row) & vbCr
4437     Next
4438     
4439     If cc_RangeDeclarations.Count > 0 Then str_CodePart = str_CodePart & vbCr
4440             
4441 'TABLES
4442     For lng_Row = 1 To cc_TableDeclarations.Count
4443         If Not z_mLinkExcelObjects_Codefind(CodePan, cc_TableDeclarations.Item(lng_Row)) Then
4444             Debug.Print "Added Link for " & Split(cc_TableDeclarations.Item(lng_Row), " ")(1)
4445         End If
4446         str_CodePart = str_CodePart & cc_TableDeclarations.Item(lng_Row) & vbCr
4447     Next
4448     
4449     If cc_TableDeclarations.Count > 0 Then str_CodePart = str_CodePart & vbCr
4450     
4451 'PIVOTS
4452     For lng_Row = 1 To cc_PivotDeclarations.Count
4453         If Not z_mLinkExcelObjects_Codefind(CodePan, cc_PivotDeclarations.Item(lng_Row)) Then
4454             Debug.Print "Added Link for " & Split(cc_PivotDeclarations.Item(lng_Row), " ")(1)
4455         End If
4456         str_CodePart = str_CodePart & cc_PivotDeclarations.Item(lng_Row) & vbCr
4457     Next
4458         
4459     If cc_PivotDeclarations.Count > 0 Then str_CodePart = str_CodePart & vbCr
4460       
4461         
4462 'FUNCTION
4463         
4464     str_CodePart = str_CodePart & vbCr & "Function LinkWorkbookTables()" & vbCr & vbCr
4465         
4466 
4467     For lng_Row = 1 To cc_RangeInitiation.Count
4468         str_CodePart = str_CodePart & vbTab & cc_RangeInitiation.Item(lng_Row) & vbCr
4469     Next
4470     
4471     If cc_RangeInitiation.Count > 0 Then str_CodePart = str_CodePart & vbCr
4472             
4473     For lng_Row = 1 To cc_TableInitiation.Count
4474         str_CodePart = str_CodePart & vbTab & cc_TableInitiation.Item(lng_Row) & vbCr
4475     Next
4476     
4477     If cc_TableInitiation.Count > 0 Then str_CodePart = str_CodePart & vbCr
4478     
4479     For lng_Row = 1 To cc_PivotInitiation.Count
4480         str_CodePart = str_CodePart & vbTab & cc_PivotInitiation.Item(lng_Row) & vbCr
4481     Next
4482     
4483     If cc_PivotInitiation.Count > 0 Then str_CodePart = str_CodePart & vbCr
4484     
4485     str_CodePart = str_CodePart & "End Function" & vbCr & vbCr
4486         
4487         
4488 'CLEAR & PRINT NEW
4489     Call zCodeRemove("mod_AtkBindings")
4490     Call zCodeAppend(str_CodePart, "mod_ATkBindings")
4491     
4492 End Function
4493 
4494 Private Function z_mLinkExcelObjects_Codefind( _
4495     ByRef obj_Module As Object, _
4496     ByVal str_FindCase As String, _
4497     Optional ByRef StartLine As Long = 1, _
4498     Optional ByRef EndLine As Long = -1, _
4499     Optional ByRef StartColumn As Long = 1, _
4500     Optional ByRef EndColumn As Long = 255, _
4501     Optional ByVal Wholeword As Boolean = False, _
4502     Optional ByVal MatchCase As Boolean = True, _
4503     Optional ByVal Patternsearch As Boolean = False) As Boolean
4504 
4505     With obj_Module
4506 
4507         If EndLine = -1 Then EndLine = .CountOfLines
4508 
4509         z_mLinkExcelObjects_Codefind = .Find( _
4510                                         Target:=str_FindCase, _
4511                                         StartLine:=StartLine, _
4512                                         StartColumn:=StartColumn, _
4513                                         EndLine:=EndLine, _
4514                                         EndColumn:=EndColumn, _
4515                                         Wholeword:=Wholeword, _
4516                                         MatchCase:=MatchCase, _
4517                                         Patternsearch:=Patternsearch)
4518     End With
4519 
4520 End Function
4521 
4522 
4523 Private Function z_mLinkExcelObjects_AddCode( _
4524     ByRef CodePan As Object, _
4525     ByRef cc_Declarations As Collection, _
4526     ByRef cc_Initiations As Collection, _
4527     ByRef lng_GlobalLastRowInput As Long, _
4528     ByRef lng_InitiateLastRowInput As Long)
4529 
4530 
4531     Dim lng_GlobalLastRow As Long
4532     Dim lng_InitiateLastRow As Long
4533     Dim i_StatementCursor As Long
4534     Dim SL As Long
4535      
4536     'IDENTIFY EXISTING GLOBAL VARIABLES ROW
4537     For i_StatementCursor = cc_Declarations.Count To 1 Step -1
4538         If z_mLinkExcelObjects_Codefind(CodePan, cc_Declarations.Item(i_StatementCursor), SL) Then
4539         
4540             Call cc_Declarations.Remove(i_StatementCursor)
4541             If SL > lng_GlobalLastRow Then lng_GlobalLastRow = SL
4542             SL = 1
4543         End If
4544     Next
4545 
4546         
4547     'ADD NOT YET ADDED VARIABLES
4548     If cc_Declarations.Count > 0 Then
4549     
4550         If lng_GlobalLastRow = 0 Then
4551             Call z_mPP(lng_GlobalLastRowInput) 'lng_GlobalLastRowInput + 1
4552             Call z_mPP(lng_InitiateLastRowInput)
4553             
4554             Call z_mLinkExcelObjects_WriteLine(CodePan, "", lng_GlobalLastRowInput)
4555 
4556         Else
4557             lng_GlobalLastRowInput = lng_GlobalLastRow
4558         End If
4559     
4560         For i_StatementCursor = cc_Declarations.Count To 1 Step -1
4561             Call z_mPP(lng_GlobalLastRowInput) 'lng_GlobalLastRowInput + 1
4562             Call z_mPP(lng_InitiateLastRowInput) 'lng_InitiateLastRow + 1
4563             
4564             Call z_mLinkExcelObjects_WriteLine(CodePan, cc_Declarations.Item(i_StatementCursor), lng_GlobalLastRowInput)
4565             
4566             Debug.Print "Added Link for " & Split(cc_Declarations.Item(i_StatementCursor), " ")(1)
4567         Next
4568     
4569     Else
4570         lng_GlobalLastRowInput = lng_GlobalLastRow
4571     End If
4572 
4573           
4574     'FIND PROCEDURE OR ADD PROCEDURE IF NOT EXIST
4575     For i_StatementCursor = cc_Initiations.Count To 1 Step -1
4576         If z_mLinkExcelObjects_Codefind(CodePan, cc_Initiations.Item(i_StatementCursor), SL) Then
4577         
4578             Call cc_Initiations.Remove(i_StatementCursor)
4579             If SL > lng_InitiateLastRow Then lng_InitiateLastRow = SL
4580             SL = lng_InitiateLastRowInput
4581         
4582         End If
4583     Next
4584 
4585     'ADD NOT YET ADDED INITIATITIONS
4586     If cc_Initiations.Count > 0 Then
4587     
4588         If lng_InitiateLastRow = 0 Then
4589             Call z_mPP(lng_InitiateLastRowInput)
4590             Call z_mLinkExcelObjects_WriteLine(CodePan, "", lng_InitiateLastRowInput)
4591         Else
4592             lng_InitiateLastRowInput = lng_InitiateLastRow
4593         End If
4594     
4595         For i_StatementCursor = cc_Initiations.Count To 1 Step -1
4596             Call z_mPP(lng_InitiateLastRowInput)
4597             Call z_mLinkExcelObjects_WriteLine(CodePan, vbTab & cc_Initiations.Item(i_StatementCursor), lng_InitiateLastRowInput)
4598         Next
4599     
4600     Else
4601         lng_InitiateLastRowInput = lng_InitiateLastRow
4602     End If
4603 
4604 End Function
4605 
4606 Private Function z_mLinkExcelObjects_WriteLine(ByRef obj_Codepane As Object, ByVal str_Text As String, ByVal lng_Line As Long)
4607     Call obj_Codepane.InsertLines(lng_Line, str_Text)
4608     
4609     'Debug.Print lng_Line & vbTab & str_Text
4610 End Function
4611 
4612 Private Function z_mPP(ByRef lng_Counter As Long)
4613     lng_Counter = lng_Counter + 1
4614 End Function
4615 
4616 Function xAddButton(ByVal str_ButtonCaption As String, Optional ByVal bool_ChewieButton = False)
4617     
4618     Dim shape_Cursor As Shape
4619 
4620     'chewie initial blocks
4621     If bool_ChewieButton Then
4622         If Not zModuleExists("clsSap") And Not zModuleExists("clsCollection") Then
4623             MsgBox "Can't add chewie missing SAP class modules ... Exiting"
4624             Exit Function
4625         End If
4626     End If
4627 
4628     Dim str_ButtonName As String
4629     Dim str_ActionName As String
4630     
4631     str_ActionName = Replace(WorksheetFunction.Proper(Trim(str_ButtonCaption)), " ", "")
4632     str_ButtonName = "btn_" & str_ActionName
4633 
4634     If zProdedureExists(str_ButtonName, "mod_AtkMain") Then
4635         MsgBox "There is already button with same name ... Exiting"
4636         Exit Function
4637     End If
4638 
4639     Dim CodePan As Object 'VBIDE.CodeModule
4640 
4641     Dim lng_ControlsTop As Long
4642     Dim lng_Top As Long
4643     Dim lng_Height As Long
4644     Dim lng_Left As Long
4645     
4646     lng_Top = ThisWorkbook.Sheets("Main").Range("B11").Top
4647     lng_Height = ThisWorkbook.Sheets("Main").Range("B1:B2").Height
4648     lng_Left = ThisWorkbook.Sheets("Main").Range("B1").Left
4649 
4650     lng_ControlsTop = lng_Top
4651 
4652     'find Lowest Button on main sheet
4653     For Each shape_Cursor In sht_Main.Shapes
4654     
4655         If shape_Cursor.Name Like "btn_*" Then
4656     
4657             If shape_Cursor.OnAction <> "" Then
4658             
4659                 If shape_Cursor.Top + shape_Cursor.Height > lng_ControlsTop Then lng_ControlsTop = shape_Cursor.Top + shape_Cursor.Height
4660                 
4661             End If
4662         
4663         End If
4664     
4665     Next
4666     
4667     'check size add one more button size
4668     If lng_ControlsTop = lng_Top + lng_Height Then lng_ControlsTop = lng_ControlsTop + lng_Height
4669 
4670     'Clean up
4671     On Error Resume Next
4672         ThisWorkbook.Sheets("Main").Shapes("btn_ButtonTemplate").Delete
4673     On Error GoTo 0
4674 
4675     'DUPLICATE BUTTON
4676     ThisWorkbook.Sheets("ATk").Shapes("btn_ButtonTemplate").Copy
4677     ThisWorkbook.Sheets("Main").Paste
4678     
4679     
4680     Dim new_Button As Shape
4681     Set new_Button = ThisWorkbook.Sheets("Main").Shapes("btn_ButtonTemplate")
4682     
4683     new_Button.Top = lng_ControlsTop
4684     new_Button.Left = lng_Left
4685     new_Button.Name = str_ButtonName
4686     new_Button.TextFrame2.TextRange.Characters.Text = str_ButtonCaption
4687     new_Button.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
4688     new_Button.OnAction = str_ButtonName
4689     
4690     Dim str_NewProcedure As String
4691     
4692     Dim str_Path As String
4693     Dim strcode As String
4694     
4695     If bool_ChewieButton Then
4696          
4697         'Pick VBS Script
4698         Select Case MsgBox("Select any VBS file ?", vbYesNoCancel, "Import SAPGUI Check")
4699             
4700             Case vbYes
4701                 str_Path = Application.GetOpenFilename
4702         
4703                 Do While str_Path = ""
4704                     str_Path = Application.GetOpenFilename
4705                 Loop
4706                 
4707                 strcode = z_ChewCode(str_Path)
4708                 
4709             Case vbNo
4710             
4711                 strcode = z_ChewCode("skip")
4712                 
4713             Case vbCancel
4714                 Exit Function
4715                 
4716         End Select
4717         
4718         'Get Code Module
4719         Call shtATk.zCodeAppend(Replace(strcode, "XSUBROUTINENAME", str_ActionName), "mod_Chewie")
4720       
4721 
4722 
4723         str_NewProcedure = Join(Array( _
4724             "Public Sub " & str_ButtonName & "()", _
4725             "", _
4726             vbTab & "With shtATk", _
4727             vbTab & vbTab & ".MacroStart", _
4728              "", _
4729             vbTab & vbTab & "Call mod_Chewie." & str_ActionName & "(t_Parameters, t_Input, t_Log)", _
4730             vbTab & vbTab & "' your script goes here", _
4731              "", _
4732             vbTab & vbTab & ".MacroFinish", _
4733             vbTab & "End With", _
4734             "", _
4735             "End Sub"), vbCr)
4736     Else
4737     
4738         str_NewProcedure = Join(Array( _
4739             "Public Sub " & str_ButtonName & "()", _
4740             "", _
4741             vbTab & "With shtATk", _
4742             vbTab & vbTab & ".MacroStart", _
4743              "", _
4744             vbTab & vbTab & "' your script goes here", _
4745              "", _
4746             vbTab & vbTab & ".MacroFinish", _
4747             vbTab & "End With", _
4748             "", _
4749             "End Sub"), vbCr)
4750     End If
4751         
4752     Call zCodeAppend(str_NewProcedure, "mod_AtkMain")
4753 
4754 End Function
4755 
4756 Private Function z_ChewCode(ByVal str_Path) As String
4757     
4758     'moved to private function to prevent compile error if clsSap class module is missing
4759     
4760     Dim clsSap As Object
4761     Set clsSap = New clsSap
4762 
4763     z_ChewCode = clsSap.SapChewVBS(str_Path)
4764      
4765     Set clsSap = Nothing
4766     
4767 End Function
4768 
4769 Function zSelectCodePan(ByRef CodePan As Variant, ByVal str_CodeModuleName As String, Optional ByVal wbk_Target As Workbook = Nothing) As Boolean
4770 
4771     Dim vbProj As Object
4772     Dim VBComp As Object
4773 
4774 
4775     If wbk_Target Is Nothing Then Set wbk_Target = ThisWorkbook
4776 
4777     Set vbProj = wbk_Target.VBProject
4778     
4779     On Error Resume Next
4780     
4781     Set VBComp = vbProj.VBComponents(str_CodeModuleName)
4782     
4783     On Error GoTo 0
4784     
4785     If VBComp Is Nothing Then
4786     
4787         Set VBComp = vbProj.VBComponents.Add(1) '1 = vbext_ct_StdModule
4788         VBComp.Name = str_CodeModuleName
4789     
4790     End If
4791     
4792     Set CodePan = VBComp.CodeModule
4793     
4794 End Function
4795 
4796 Function zProdedureExists(ByVal str_ProcName As String, ByVal str_CodeModuleName As String, Optional ByVal wbk_Target As Workbook = Nothing) As Boolean
4797 
4798     Dim VBComp As Object
4799 
4800 
4801     If wbk_Target Is Nothing Then Set wbk_Target = ThisWorkbook
4802 
4803     If Not zModuleExists(str_CodeModuleName, wbk_Target) Then
4804         MsgBox "Module called " & str_CodeModuleName & " not found ... Exiting"
4805         Exit Function
4806     End If
4807     
4808      'ENTER CODE
4809     Call zSelectCodePan(VBComp, "mod_AtkMain", wbk_Target)
4810 
4811     Dim StartLine As Long
4812     Dim NumLines As Long
4813     Dim ProcName As String
4814 
4815     On Error GoTo Err
4816     With VBComp
4817         StartLine = .ProcStartLine(str_ProcName, 0)
4818     End With
4819 
4820 Err:
4821     If Err.Number = 0 Then
4822         zProdedureExists = True
4823     Else
4824         zProdedureExists = False
4825     End If
4826     
4827     Err.Clear
4828 
4829 End Function
4830 
4831 Function xAddPicker(ByVal str_PickerName As String, Optional lng_PickerType As e_PickerType = e_FilePicker)
4832 
4833 On Error GoTo Err
4834 
4835     Dim lng_Top As Long
4836     Dim lng_Width As Long
4837     Dim lng_Height As Long
4838     Dim lng_Left As Long
4839     
4840     Dim ole_Cursor As OLEObject
4841     
4842     'sht main teplate button
4843     lng_Width = ThisWorkbook.Sheets("ATk").Shapes("btn_PickerTemplate").Width
4844     lng_Height = ThisWorkbook.Sheets("ATk").Shapes("btn_PickerTemplate").Height
4845     
4846     Dim lng_ControlsTop As Long
4847     
4848     Dim str_PickerCodeName As String
4849     Dim str_ButtonName As String
4850     
4851     str_PickerCodeName = Replace(WorksheetFunction.Proper(Trim(str_PickerName)), " ", "")
4852     str_ButtonName = "btn_" & str_PickerCodeName
4853     
4854     'Existing Procedure Check
4855     If zProdedureExists(str_ButtonName, "mod_AtkMain") Then
4856         MsgBox "There is already button with same name ... Exiting"
4857         Exit Function
4858     End If
4859     
4860     Dim rng_Cursor As Range
4861     Dim rng_Link As Range
4862     
4863     For Each rng_Cursor In ThisWorkbook.Sheets("Main").Range("I11:I30")
4864         On Error Resume Next
4865         Dim str_Name As String
4866         str_Name = ""
4867         str_Name = rng_Cursor.Name
4868         On Error GoTo 0
4869         If str_Name = "" And rng_Cursor.Offset(, -1) = "" And rng_Cursor.Offset(, -2) = "" And rng_Cursor = "" Then
4870             Set rng_Link = rng_Cursor
4871             Exit For
4872         End If
4873     Next
4874     
4875     'add named range
4876     rng_Link.Name = "rng_" & str_PickerCodeName
4877     
4878     'Clean up
4879     On Error Resume Next
4880         ThisWorkbook.Sheets("Main").Shapes("btn_PickerTemplate").Delete
4881     On Error GoTo Err
4882 
4883     'DUPLICATE BUTTON
4884     ThisWorkbook.Sheets("ATk").Shapes("btn_PickerTemplate").Copy
4885     ThisWorkbook.Sheets("Main").Paste
4886     
4887     Dim new_Button As Shape
4888     Set new_Button = ThisWorkbook.Sheets("Main").Shapes("btn_PickerTemplate")
4889 
4890     new_Button.Top = lng_ControlsTop
4891     new_Button.Name = str_ButtonName
4892     new_Button.Left = rng_Link.Left - lng_Width
4893     new_Button.Top = rng_Link.Top
4894     new_Button.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
4895     new_Button.OnAction = str_ButtonName
4896 
4897     With rng_Link.Offset(, -1)
4898         .HorizontalAlignment = xlRight
4899         .VerticalAlignment = xlBottom
4900         .WrapText = False
4901         .Orientation = 0
4902         .AddIndent = False
4903         .IndentLevel = 0
4904         .ShrinkToFit = False
4905         .ReadingOrder = xlContext
4906         .MergeCells = False
4907         .Value = str_PickerName
4908         .InsertIndent 4
4909         .Font.Bold = True
4910     End With
4911 
4912      'ENTER CODE
4913     'Call zSelectCodePan(CodePan, "mod_AtkMain")
4914 
4915     Dim str_ActionName As String
4916 
4917     Select Case lng_PickerType
4918         Case e_FilePicker: str_ActionName = "FilePicker"
4919         Case e_FolderPicker: str_ActionName = "FolderPicker"
4920         Case e_OutlookPicker: str_ActionName = "FolderPickerOutlook"
4921     End Select
4922 
4923     Dim str_NewProcedure As String
4924     
4925     str_NewProcedure = Join(Array( _
4926         "Public Sub " & str_ButtonName & "()", _
4927         "", _
4928         vbTab & "With shtATk", _
4929         vbTab & vbTab & ".MacroStart", _
4930          "", _
4931         vbTab & vbTab & "Call ." & str_ActionName & "(rng_" & str_PickerCodeName & ", ""Please select " & str_PickerName & """)", _
4932          "", _
4933         "MACRO_FINISH:", _
4934         vbTab & vbTab & ".MacroFinish", _
4935         vbTab & "End With", _
4936         "", _
4937         "End Sub"), vbCr)
4938 
4939     Call zCodeAppend(str_NewProcedure, "mod_AtkMain")
4940 
4941     DoEvents
4942     Call xLinkExcelObjects
4943 
4944 Exit Function
4945 Err:
4946 
4947 Err.Raise Err.Number
4948 Resume
4949 
4950 End Function
4951 
4952  Function zRemoveProcedure(ByVal str_ProcName As String, ByVal str_ModuleName As String, Optional ByRef wbk_Target As Workbook = Nothing) As Boolean
4953 
4954     If wbk_Target Is Nothing Then Set wbk_Target = ThisWorkbook
4955     
4956     Dim CodePan As Object
4957     
4958     'ENTER CODE
4959     Call zSelectCodePan(CodePan, "mod_AtkMain", wbk_Target)
4960 
4961     Dim StartLine As Long
4962     Dim NumLines As Long
4963     Dim ProcName As String
4964 
4965     With CodePan
4966         StartLine = .ProcStartLine(str_ProcName, vbext_pk_Proc)
4967         NumLines = .ProcCountLines(str_ProcName, vbext_pk_Proc)
4968         .DeleteLines StartLine:=StartLine, Count:=NumLines
4969     End With
4970 
4971 End Function
4972 
4973  Function zModuleExists(ByVal str_ModuleName As String, Optional ByRef wbk_Target As Workbook = Nothing) As Boolean
4974 
4975     If wbk_Target Is Nothing Then Set wbk_Target = ThisWorkbook
4976 
4977     Dim vbProj As Object
4978     Dim VBComp As Object
4979    
4980     Set vbProj = wbk_Target.VBProject
4981     
4982     On Error Resume Next
4983     
4984     Set VBComp = vbProj.VBComponents(str_ModuleName)
4985     
4986     On Error GoTo 0
4987     
4988     zModuleExists = Not VBComp Is Nothing
4989 
4990 End Function
4991 
4992  Function zCodeGet(ByRef arr_Code As Variant, ByVal str_ModuleName As String, Optional ByRef wbk_Target As Workbook = Nothing) As Boolean
4993     
4994     Dim CodePan As Object
4995 
4996      'ENTER CODE
4997     Call zSelectCodePan(CodePan, str_ModuleName, wbk_Target)
4998 
4999     'Dim arr_Code()
5000 
5001     With CodePan
5002         arr_Code = Split(.lines(1, .CountOfLines), vbLf)
5003     End With
5004 
5005     zCodeGet = True
5006     
5007 End Function
5008 
5009 Function zCodeAppend(ByVal str_Code As String, ByVal str_ModuleName As String, Optional ByRef wbk_Target As Workbook = Nothing) As Boolean
5010     
5011     Dim CodePan As Object
5012     
5013     'ENTER CODE
5014     Call zSelectCodePan(CodePan, str_ModuleName, wbk_Target)
5015 
5016     With CodePan
5017         Call .InsertLines(IIf(.CountOfLines = 0, 1, .CountOfLines), str_Code)
5018     End With
5019 
5020 
5021 End Function
5022 
5023 Function xAddParameter( _
5024     ByVal str_ParameterName As String) As Boolean
5025 
5026 On Error GoTo Err
5027 
5028     DoEvents
5029     Call xLinkExcelObjects
5030 
5031     Dim ole_Cursor As OLEObject
5032     
5033     'sht main teplate butto
5034     Dim lng_ControlsTop As Long
5035     
5036     'find Lowest Button on main sheet
5037     Dim rng_Cursor As Range
5038     Dim rng_Link As Range
5039     
5040     For Each rng_Cursor In ThisWorkbook.Sheets("Main").Range("I11:I30")
5041         On Error Resume Next
5042         Dim str_Name As String
5043         str_Name = ""
5044         str_Name = rng_Cursor.Name
5045         On Error GoTo 0
5046         If str_Name = "" And rng_Cursor.Offset(, -1) = "" And rng_Cursor.Offset(, -2) = "" And rng_Cursor = "" Then
5047             Set rng_Link = rng_Cursor
5048             Exit For
5049         End If
5050     Next
5051     
5052     'add named range
5053     rng_Link.Name = "rng_" & Replace(WorksheetFunction.Proper(Trim(str_ParameterName)), " ", "")
5054     
5055     With rng_Link.Offset(, -1)
5056         .Value = str_ParameterName & " :"
5057         .HorizontalAlignment = xlRight
5058         .AddIndent = False
5059         .IndentLevel = 0
5060     End With
5061 
5062     DoEvents
5063     Call xLinkExcelObjects
5064 
5065 Exit Function
5066 Err:
5067 
5068 Err.Raise Err.Number
5069 Resume
5070 
5071 End Function
5072 
5073 Function TableAddRowByMap( _
5074     ByRef tbl_SourceTable As ListObject, _
5075     ByRef tbl_MapTable As ListObject, _
5076     Optional ByRef wbk_Source As Workbook) As Boolean
5077     
5078     Dim arr_HeaderColumns
5079     Dim arr_Map()
5080     
5081     Dim wbk_Temp As Workbook
5082     
5083     If wbk_Source Is Nothing Then
5084         Set wbk_Temp = ThisWorkbook
5085     Else
5086         Set wbk_Temp = wbk_Source
5087     End If
5088     
5089     arr_HeaderColumns = WorksheetFunction.Index(tbl_SourceTable.HeaderRowRange, 1, 0)
5090     
5091     Dim lng_Cursor As Long
5092     
5093     arr_Map = tbl_MapTable.Range
5094     
5095     Dim lng_TableNewLine As Long
5096     
5097     Dim lng_SheetIndex As Long
5098     Dim lng_RangeRef As Long
5099     Dim lng_TargetColumn As Long
5100     
5101     Dim lng_TableFirstColumn As Long
5102     
5103     lng_TableFirstColumn = tbl_MapTable.HeaderRowRange.Resize(1, 1).Column - 1
5104     
5105     With tbl_MapTable.HeaderRowRange
5106         
5107         lng_SheetIndex = .Find("Sheet").Column - lng_TableFirstColumn
5108         lng_RangeRef = .Find("Range").Column - lng_TableFirstColumn
5109         lng_TargetColumn = .Find("ColumnName").Column - lng_TableFirstColumn
5110          
5111     End With
5112     
5113     
5114     Dim lng_OffsetRow As Long
5115     
5116     
5117     lng_OffsetRow = tbl_SourceTable.Range.Rows.Count
5118     
5119     If lng_OffsetRow = 2 Then
5120         
5121         Dim rng_FirstRow As Range
5122         On Error Resume Next
5123         Set rng_FirstRow = tbl_SourceTable.HeaderRowRange.Offset(1).SpecialCells(xlCellTypeConstants)
5124         On Error GoTo 0
5125         
5126         If rng_FirstRow Is Nothing Then
5127             lng_OffsetRow = 1
5128         End If
5129     
5130     End If
5131     
5132     
5133     With tbl_SourceTable.HeaderRowRange.Offset(lng_OffsetRow)
5134 
5135 
5136         For lng_Cursor = LBound(arr_Map) + 1 To UBound(arr_Map)
5137             
5138             On Error Resume Next
5139              .Cells(1, Application.Match(arr_Map(lng_Cursor, lng_TargetColumn), arr_HeaderColumns, 0)) = wbk_Temp.Sheets(arr_Map(lng_Cursor, lng_SheetIndex)).Range(arr_Map(lng_Cursor, lng_RangeRef)).Value
5140             On Error GoTo 0
5141         
5142         Next
5143         
5144     .Calculate
5145     
5146     End With
5147 
5148 
5149 End Function
5150 
5151 
5152 
5153 Public Sub zATK_Issue()
5154 
5155     MacroStart
5156         
5157     Dim obj_Email As Object
5158     
5159     Call EmailCreateNew(obj_Email, Array( _
5160                         "<a href=""" & ThisWorkbook.Path & """>BAU</a>", _
5161                         "<a href=""" & rng_ManualLink.Text & """>MAN</a>"), _
5162                         ThisWorkbook.Name, _
5163                         "jan.becka@ab-inbev.com")
5164     
5165     
5166     Call EmailAttachWorkbook(obj_Email, ThisWorkbook)
5167     
5168     MacroFinish
5169 
5170 End Sub
5171 
5172 
5173 Public Sub zATK_PickManual()
5174 
5175     MacroStart
5176         
5177     Call shtATk.FilePicker(rng_ManualLink, "Please select Manual File")
5178         
5179     MacroFinish
5180     
5181 End Sub
5182 
5183 
5184 Sub zCodeRemove(ByVal str_ModuleName As String, Optional ByRef wbk_Target As Workbook = Nothing)
5185 
5186   
5187     Dim codemod As Object
5188   
5189     Call shtATk.zSelectCodePan(codemod, str_ModuleName, wbk_Target)
5190     
5191     With codemod
5192         .DeleteLines 1, .CountOfLines
5193     End With
5194 
5195 End Sub
5196 
5197 Function zCodeExport(ByVal str_ModuleName) As Boolean
5198     
5199     Dim arr_Code
5200     
5201     Call zCodeGet(arr_Code, str_ModuleName)
5202 
5203     Dim file_Output As Object
5204 
5205     With CreateObject("Scripting.FileSystemObject")
5206     
5207         'write file
5208         With .CreateTextFile(ThisWorkbook.Path & "\" & str_ModuleName & ".vb", True)
5209       
5210             Call .WriteLine(Join(arr_Code))
5211             Call .Close
5212 
5213         End With
5214 
5215     End With
5216 
5217     zCodeExport = True
5218 
5219 End Function
5220 Function zCodeImport(ByVal str_ModuleName) As Boolean
5221 
5222     zCodeImport = False
5223 
5224     Dim str_Code As String
5225 
5226     With CreateObject("Scripting.FileSystemObject")
5227     
5228         If .FileExists(ThisWorkbook.Path & "\" & str_ModuleName & ".vb") = False Then
5229             Call MsgBox("File with module not found exitting ...")
5230             Exit Function
5231         End If
5232     
5233         With .OpenTextFile(ThisWorkbook.Path & "\" & str_ModuleName & ".vb", 1)
5234 
5235             str_Code = .ReadAll
5236             .Close
5237 
5238         End With
5239 
5240     End With
5241     
5242     Call zCodeRemove(str_ModuleName)
5243     Call zCodeAppend(str_Code, str_ModuleName)
5244     
5245     zCodeImport = True
5246 
5247 End Function