Option Explicit '############## Macros and procedures for generating Excel contents table ############ ' 'Copyrights by EDV Abmayr 2010: 'Author: Bernhard Abmayr 'Contact see www.edv-abmayr.de 'These macros may be copied, used and modified freely for private and other not commercial 'purpose. You may give them or parts of them freely to others only together with the 'information about the author, the exclusion of liability and the copyright. 'These macros or parts of them must not be sold and they must not be used for commercial 'purpose without permission of the author. For this you need a license after 'testing the macro for your purpose for a maximum of 2 weeks. ' 'Exclusion of liability: 'The user of the macros is alone responisble for the results, I herewith deny any 'liability of my person! These macros can contain program errors. Many macros overwrite 'the content of special cells. This content is lost, as the execution of macros cannot 'be undone. 'Tip: Test new macros with a sample file. Save the file before executing a macro. ' Then the file can be reloaded, if the result was bad. '------------ CONSTANTS FOR CONTENTS GENERATION TO BE MODIFIED -------------------------------------- ' These constants may be modified to control the output of the contents ' For any reason these constants must be defined before any Procedure definition ' Public Const WS_CONTENT_NAME = "ACTUAL_WORKSHEET" ' = "ACTUAL_WORKSHEET": write the contents into the actual worksheet (ensure that there is enough empty space at the top!) Public Const WS_CONTENT_NAME = "_Contents_" ' Name of the contents worksheet Public Const START_ROW = 4 ' row where contents entries start Public Const START_COLUMN = 1 ' column where contents entries start Public Const SORTING = 1 ' 0: do not sort the contents table ' 1: Sort by "displayed text" ' 2: Sort by "referenced Address: first by row number, then by column number ' 3: Sort by "referenced Address: first by colmun number, then by row number Public Const ADD_WORKSHEET_NAME = 0 ' 1: add the worksheet name in front of the displayed hyperlink text ' 0: only display the text of the selected cell Public Const DIFFERENT_COLUMNS_FOR_EACH_WORKSHEET = 1 ' 0: write content entries of all worksheets to column start_column ' 1: write an own column for each worksheet with its name in row start_row - 1 Public Const ADD_NAME_FOR_THE_CELL = 4 ' 0: do not add a cell name ' 1: add the cell text as cell name ' 2: add the cell text as cell name only if there is no other cell name ' 3: add a new content-counter-name for the cell name (Old name is not deleted. Multiple names for a cell are possible!) ' 4: add a new content-counter-name for the cell name only if there is no other content-name for this cell ' 5: add new content-counter-name after deletion of the old content-counter-name (only those!). This is used by the restore macro. Public Const ADD_WS_TO_CELL_NAME = 0 ' 1: add the worksheet name in front of the cell name ' 0: make cell name without worksheet name Public Const USE_NAME_FOR_REFERENCING = 1 ' 0: use the cell address for referencing (-> If the cell address changes (e.g. by insertion of a row), the link refers to the old address!) ' 1: use the cell name for referencing (an error will occur if there is no name!) Public Const TEXT_TO_DISPLAY = 3 ' The text that is displayed in the table of contents for the selected cell ' 1: cell text as displayed in the selected cell ' 2: cell name (entered by the user or automatically). If there is no cell name, method 1 is used instead. ' 3: cell name, if it is not a content-counter-name, cell text else Public Const AVOID_DOUBLETS = 1 ' 1: A new hyperlink for the selected cell is inserted only if there in not already a link to this cell ' 0: double hyperlinks are inserted too. Public Const MARK_CELL = 2 ' How to mark each cell added to the contents: ' 0: do not mark it ' 1: add a comment (cell name). This works only if ADD_NAME_FOR_THE_CELL > 0 ' 2: change font of the cell (parameters see below). This works also if ADD_NAME_FOR_THE_CELL = 0 ' Using this feature you can see easily, which cells have been added to the contents! ' Following constants are only used, if MARK_CELL = 2 ' If any parameter is negative, this font parameter is not changed. ' The parameters may be specified either by an numerical value or the ' EXCEL constant Public Const BACKGROUND_COLOR = 36 Public Const FONT_COLOR = -1 Public Const FONT_NAME = "" ' empty string -> do not change font name Public Const FONT_SIZE = -1 ' if the font size increase, the Excel may increase the cell height automatically! Public Const FONT_UNDERLINED = -1 ' samples: xlUnderlineStyleSingle, xlUnderlineStyleNone (-1: do not change) Public Const FONT_BOLD = -1 ' 1: bold, 0: normal, -1: do not change '------------ END OF: CONSTANTS FOR CONTENTS GENERATION TO BE MODIFIED -------------------------------------- Sub add_to_contents() Call do_add_to_contents(ADD_NAME_FOR_THE_CELL, 1) End Sub Sub restore_contents_table() ' 'Copyrights by EDV Abmayr 2010: 'Author: Bernhard Abmayr 'Contact see www.edv-abmayr.de 'These macros may be copied, used and modified freely for private and other not commercial 'purpose. You may give them or parts of them freely to others only together with the 'information about the author, the exclusion of liability and the copyright. 'These macros or parts of them must not be sold and they must not be used for commercial 'purpose without permission of the author. For this you need a license after 'testing the macro for your purpose for a maximum of 2 weeks. ' 'Exclusion of liability: 'The user of the macros is alone responisble for the results, I herewith deny any 'liability of my person! These macros can contain program errors. Many macros overwrite 'the content of special cells. This content is lost, as the execution of macros cannot 'be undone. 'Tip: Test new macros with a sample file. Save the file before executing a macro. ' Then the file can be reloaded, if the result was bad. Dim existing_name As name Dim cell_name As String Dim row As Long Dim col As Long Dim ws_name As String Dim wb_name As String Dim ws As Worksheet Dim mbr As VbMsgBoxResult Dim add_name_for_cell As Integer Dim use_all_names As Boolean ' True : Add alls cells with cell names ' False: Add only cells with content names "c_..." use_all_names = False add_name_for_cell = 0 mbr = MsgBox("JA : Verwende alle Zellen mit einem Zellnamen zur Erzeugung des Inhaltsverzeichnisses." _ & Chr(13) & "NEIN: Verwende nur die Zellen mit einem Zellnamen, der mit c_ beginnt." & Chr(13) _ & Chr(13) & "YES: Use all cells with a cell-name to generate the table of contents." _ & Chr(13) & "NO : Use only cells with a cell-name starting witch c_.", _ vbYesNoCancel + vbDefaultButton2, "Makro restore_contents_table --- Use all cell-names?") If mbr = vbCancel Then Exit Sub ElseIf mbr = vbYes Then use_all_names = True Else use_all_names = False End If mbr = MsgBox("JA : Lösche die alten Zellnamen (nur Zählernamen) und erzeuge neue." _ & Chr(13) & "NEIN: Ändere die Zählernamen nicht." & Chr(13) _ & Chr(13) & "YES: Delete old cell names (only content-counter-names) and generate new content-counter-names." _ & Chr(13) & "NO : Do not change cell names.", _ vbYesNoCancel + vbDefaultButton2, "Makro restore_contents_table --- Delete old content-counter-names?") If mbr = vbCancel Then Exit Sub ElseIf mbr = vbYes Then add_name_for_cell = 5 Else add_name_for_cell = 0 End If ' Names can be defined on workbook level (ActiveWorkbook.Names) ' or on worksheet level (ws.Names)! ' Normally the cell names are stored at workbook level. But if we copy ' a ws, Excel copies the names too and stores the new names only in the ' new ws to avoid double names. Therefore we must make two loops and hope ' that each name is stored only in one list. For Each existing_name In ActiveWorkbook.Names ' This is a copy of the code in the second loop! If is_content_name(existing_name.name) > 0 Or use_all_names Then If InStr(existing_name.Value, "#REF!") = 0 Then ' avoid names with lost reference (may be due to deletion of a cell) Call extract_adr_string(existing_name.Value, row, col, ws_name, wb_name) If row > 0 And col > 0 Then ' row = 0 in case of undef. links etc. If ActiveSheet.name <> ws_name Then ActiveWorkbook.Worksheets(ws_name).Activate End If ActiveSheet.Cells(row, col).Select Call do_add_to_contents(add_name_for_cell, 0) End If End If End If Next ' existing_name For Each ws In ActiveWorkbook.Worksheets 'ws.Range("G1").ListNames Should list all names (of workbook and ws level), but the result is a catasrophe! ws_name = ws.name For Each existing_name In ws.Names ' existing_name.value is address: "=Nahrungsmittel!$A$127" ' existing_name.name is the name: "c_5" ' When copying worksheets, Excel copies names too, but may put the ' new ws-name in front: existing_name.name = "Mary_2!c5" If is_content_name(existing_name.name) > 0 Or use_all_names Then If InStr(existing_name.Value, "#REF!") = 0 Then ' avoid names with lost reference (may be due to deletion of a cell) 'If InStr(existing_name.RefersToRange.Next.Worksheet, "Mary_") > 0 Then ' a = 1 '+++++++++++++ ' End If Call extract_adr_string(existing_name.Value, row, col, ws_name, wb_name) If row > 0 And col > 0 Then ' row = 0 in case of undef. links etc. If ActiveSheet.name <> ws_name Then ActiveWorkbook.Worksheets(ws_name).Activate End If ActiveSheet.Cells(row, col).Select Call do_add_to_contents(add_name_for_cell, 0) End If End If End If Next ' existing_name Next ' ws End Sub Sub do_add_to_contents(ByVal add_cell_name As Integer, Optional ByVal print_msg As Integer = 1) ' ' Add the selected cell(s) to the table of contents Dim selected_cell As Range ' Loop over all selected cells using this variable Dim display_text As String ' text that is displayed for the hyperlink Dim address_text As String ' address (within the Excel file) to which the hyperlink refers Dim subaddr_text As String ' subaddress. This is used by the hyperlink for referencing Dim cell_name As String ' name of a cell Dim cell_text As String ' for testing only Dim help As String ' for some calculations Dim hyl As Hyperlink ' a hyperlink used for sorting Dim rg As Range ' a range object Dim hyl_row As Long Dim hyl_col As Long ' row and column referenced by the hyperlink Dim hyl_subadr As String ' subadr of an existing hyperlink Dim comm As Comment ' The number of entries is stored as comment Dim number_of_entries As Integer ' entries in content table Dim name_is_unique As Boolean ' for testing double names Dim ws_act As Worksheet ' the active worksheet when calling the macro Dim ws_content As Worksheet ' the content worksheet to which we write the hyperlink Dim row As Integer Dim col As Integer ' row and column of the cell to which we write the hyperlink Dim insert_row As Integer ' Set, when the row for insertion is found ' -1, if doublet is to be avoided Dim counter As Integer ' a helper variable Dim sel_row As Integer Dim sel_col As Integer ' row, column of selected cell Dim existing_name As name ' Name of a cell Dim name_found As Boolean ' flag, whether name was found Dim doublet_counter As Integer ' counts how many doublets have been found '################### Presettings ############################### doublet_counter = 0 sel_row = Selection.row sel_col = Selection.Column Set ws_act = ActiveSheet If WS_CONTENT_NAME = "ACTUAL_WORKSHEET" Then Set ws_content = ws_act Else ' Find worksheet WS_CONTENT_NAME (or create it) and get number of entries of the contents table (stored as comment in A1) If find_worksheet(ws_content, WS_CONTENT_NAME, True, False) = False Then MsgBox ("Could not find / generate worksheet " & WS_CONTENT_NAME & ". Exit Makro") Exit Sub End If ws_act.Activate ' needed only if a new ws was generated, as this gets the focus End If Set comm = ws_content.Cells(1, 1).Comment ' As isObject(), isNull, =Nothing ... did not work to distinguish a valid comm from ' an invalid one, we use On Error to check this number_of_entries = -1 On Error Resume Next number_of_entries = Val(comm.Text) On Error GoTo 0 If number_of_entries = -1 Then ' no comment was existing number_of_entries = 0 ws_content.Cells(1, 1).AddComment ws_content.Cells(1, 1).Comment.Text Text:="0 entries in content table" End If '################## Loop over all selected cells ######################### For Each selected_cell In Selection ' ################### ADD NAME FOR THE CELL ? ################################# If add_cell_name > 0 Then If add_cell_name Mod 2 = 0 Then ' add name only if there is none -> look for name cell_name = "" On Error Resume Next cell_name = selected_cell.name.name On Error GoTo 0 End If If add_cell_name Mod 2 = 1 Or Len(cell_name) = 0 Then cell_name = "" If ADD_WS_TO_CELL_NAME = 1 Then cell_name = ws_act.name & "__" If add_cell_name < 3 Then ' use text as name cell_name = cell_name & selected_cell.Text Else ' make content-counter-name cell_name = cell_name & "c_" & Format(number_of_entries + 1, "00000") End If ' Avoid double names! The names are organized on workbook level (not worksheet level) Do name_is_unique = True counter = ActiveWorkbook.Names.Count ' for testing For Each existing_name In ActiveWorkbook.Names ' existing_name.value is address: "Nahrungsmittel!$A$127" ' existing_name.name is the name: "c_5" If cell_name = existing_name.name Then name_is_unique = False cell_name = cell_name & "_1" Exit For End If Next ' existing_name Loop While Not name_is_unique If add_cell_name = 5 Then ' delete old cell name(s), if they are content-counter-names ' selected_cell.name = "" ' this does not delete the name! ' counter = selected_cell.Names.Count ' this tells all existing names of the wb! ' For Each existing_name In selected_cell.Names ' this does not work, as it returns many names that do not belong to the selected cell! ' Other method, that could have problems if the cell has a mixture ' of counter names and other names: Do While is_content_name(selected_cell.name.name) = 1 If Not IsNull(selected_cell.name) Then selected_cell.name.Delete ' this works! Else Exit Do End If ' If there are multiple names, the next call to selected_cell.name will show ' the next name! ' I am not sure, what will happen, if the name belongs to a range of multiple ' cells. May be the name is deleted for all those cells, are kept? ' But this is not important here, as we delete only content-counter-names which ' are (usually) only assigned by these macros to s single cell ' test whether the next name object can be accessed counter = 22222 On Error Resume Next counter = Len(selected_cell.name.name) On Error GoTo 0 If counter = 22222 Then Exit Do End If Loop End If selected_cell.name = cell_name ' if a name already exists, this assignment removes the name from the other cell and assignes it to this cell If MARK_CELL = 1 Then selected_cell.AddComment selected_cell.Comment.Text Text:="c_" & (number_of_entries + 1) ' Following was an attempt to make the comment window smaller, but ' this does not work. selected_cell.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft selected_cell.ShapeRange.ScaleHeight 0.22, msoFalse ElseIf MARK_CELL = 2 Then ' see below End If 'address_text = ws_act.name & "!" & cell_name End If End If ' ################### CHANGE FONT OF SELECTED CELL ? ############ If MARK_CELL = 2 Then If Len(FONT_NAME) > 0 Then selected_cell.Font.name = FONT_NAME If FONT_SIZE >= 0 Then selected_cell.Font.Size = FONT_SIZE If FONT_BOLD = 0 Then selected_cell.Font.Bold = False If FONT_BOLD = 1 Then selected_cell.Font.Bold = True If FONT_UNDERLINED >= 0 Then selected_cell.Font.Underline = FONT_UNDERLINED If FONT_COLOR >= 0 Then selected_cell.Font.ColorIndex = FONT_COLOR If BACKGROUND_COLOR >= 0 Then selected_cell.Interior.ColorIndex = BACKGROUND_COLOR selected_cell.Interior.Pattern = xlSolid ' this is fix! End If End If ' ################### MAKE REFERENCE DATA ############################## address_text = ws_act.name & "!" & selected_cell.Address address_text = Replace(address_text, "$", "") ' I tried this hoping that the hyperlinks reference would move with the cell if the cell is moved. But this is not the case! So this line does not change anything. If USE_NAME_FOR_REFERENCING = 1 Then subaddr_text = selected_cell.name.name If Len(subaddr_text) = 0 Then Call MsgBox("You set USE_NAME_FOR_REFERENCING = 1, but there is no name for this cell. Check ADD_NAME_FOR_THE_CELL! This time I will do nothing!", vbOKOnly, "Macro add_to_contents") Exit Sub End If Else subaddr_text = address_text End If ' Remember the data of the selected cell for generating a link to it display_text = selected_cell.Text If TEXT_TO_DISPLAY > 1 Then help = "" On Error Resume Next ' help is changed only if a cell name exists. Else it remains empty help = selected_cell.name.name On Error GoTo 0 If Len(help) > 0 Then ' the cell has a name If TEXT_TO_DISPLAY = 2 Then display_text = help ElseIf TEXT_TO_DISPLAY = 3 Then If is_content_name(help) <> 1 Then display_text = help End If End If End If End If If ADD_WORKSHEET_NAME = 1 Then display_text = ws_act.name & " " & display_text End If ' Determine the output column ' ws_content.Activate ' this is not needed and saves time if we omit it row = START_ROW - 1 col = START_COLUMN If DIFFERENT_COLUMNS_FOR_EACH_WORKSHEET = 1 Then Do While ws_content.Cells(row, col).Text <> ws_act.name If IsEmpty(ws_content.Cells(row, col)) Then ws_content.Cells(row, col) = ws_act.name Exit Do Else col = col + 1 If col = ws_content.Columns.Count Then ' Old Excel only has 256 columns ... ws_act.Activate Call MsgBox("With DIFFERENT_COLUMNS_FOR_EACH_WORKSHEET = 1 the number of worksheets must be less than " _ & (ws_content.Columns.Count - START_COLUMN + 2), vbOKOnly, "Macro add_to_content would like to tell you:") Exit Sub End If End If Loop End If ' ###################### DETERMINE OUTPUT ROW ################### ' Determine the output row: look for the first free cell in the output column ' or until the sorting condition is matched. row = START_ROW insert_row = 0 'ws_content.Activate Do While (insert_row = 0) And (Not IsEmpty(ws_content.Cells(row, col))) cell_text = ws_content.Cells(row, col).Text If ws_content.Cells(row, col).Hyperlinks.Count > 0 Then Set hyl = ws_content.Cells(row, col).Hyperlinks.Item(1) ' ERROR? The function could fail here, if anybody changed the ' content table and added items without hyperlinks. ' This could be tested using the Count property. But what ' should I do in case of an failure? 'cc = ws_content.Cells(row, col).Hyperlinks.Count ' 1 's2 = hyl.SubAddress ' may be the name or address of the referenced cell 's1 = hyl.Address ' empty ! (only used for links to other xls-files) 'hyl.Type is always 0 (for address reference and name reference) Set rg = hyl.Range ' This is the Range of the cell containing the hyperlink, NOT of the referenced cell! hyl_row = rg.row hyl_col = rg.Column hyl_subadr = hyl.SubAddress ' If is_content_name(hyl_subadr) > 1 Then improved by next line, as this check would not find normal cell names If InStr(hyl_subadr, "$") < 1 Then ' it is a name reference and we must determine the address ' by searching the name in the name list ' if the name of the cell was deleted above due to add_cell_name = 5 ' we cannot find the name here and the new cell will be inserted even ' if AVOID_DOUBLETS = 1 name_found = False For Each existing_name In ActiveWorkbook.Names ' existing_name.value is address: "Nahrungsmittel!$A$127" ' existing_name.name is the name: "c_5" If hyl_subadr = existing_name.name Then hyl_subadr = existing_name.Value name_found = True Exit For End If Next ' existing_name ' If we had no success, look in Names of act_ws, too: For Each existing_name In ws_act.Names If hyl_subadr = existing_name.name Then hyl_subadr = existing_name.Value name_found = True Exit For End If Next ' existing_name Else ' it is a address reference already name_found = True ' for next if statement we need this End If If name_found Then Call extract_adr_string(hyl_subadr, hyl_row, hyl_col) ' Check for doublet and break loop if one is found If (AVOID_DOUBLETS = 1) And (hyl_row = sel_row) And (hyl_col = sel_col) Then insert_row = -1 doublet_counter = doublet_counter + 1 Exit Do End If Else ' if we didn't find the name, continue and add the cell as it is. End If Else ' The cell does not have a hyperlink (invalid cell in contents, but ' we must handle it in any way ' cell_text was set above hyl_row = 0 hyl_col = 0 End If If SORTING = 1 Then If StrComp(display_text, cell_text, vbTextCompare) < 1 Then ' <= instead of < enables easier doublet check below insert_row = row End If ElseIf SORTING = 2 Then If (sel_row < hyl_row) _ Or ((sel_row = hyl_row) And (sel_col <= hyl_col)) Then insert_row = row End If ElseIf SORTING = 3 Then If (sel_col < hyl_col) _ Or ((sel_col = hyl_col) And (sel_row <= hyl_row)) Then insert_row = row End If End If If (insert_row > 0) Then ws_content.Cells(row, col).Insert Shift:=xlDown Else row = row + 1 End If Loop If insert_row = 0 Then ' if it is the last entry (sorting), or sorting is inactive insert_row = row End If If insert_row > 0 Then ' Write the output using the found cell as anchor for the hyperlink insertion ' Address parameter is only for links to other Excel files, within one file ' we need only the SubAddress and Address must be empty! ActiveSheet.Hyperlinks.Add Anchor:=ws_content.Cells(row, col), Address:="", _ SubAddress:=subaddr_text, TextToDisplay:=display_text ' update the counter for content entries number_of_entries = number_of_entries + 1 ws_content.Cells(1, 1).Comment.Text Text:=number_of_entries & " entries in content table" End If Next ' selected_cell ' Return focus to the previous worksheet ' ws_act.Activate ' only needed, if ws_content is activated above '++++++++++++++++++++ Output of doublets ++++++++++++++++++++++++++++++++++++ If print_msg = 1 Then If AVOID_DOUBLETS = 1 And doublet_counter > 0 Then MsgBox (doublet_counter & " Dubletten wurden nicht ins Inhaltsverzeichnis eingefügt." & Chr(13) & Chr(13) _ & doublet_counter & " doublets were not inserted into the contents table.") End If End If '++++++++++++++++++++ Check number of calls to this macro and print msg box Dim number_of_calls As Integer number_of_calls = 0 On Error Resume Next ' The location is: HKEY_CURRENT_USER - Software - VB and VBA Program Settings - ... number_of_calls = GetSetting(appname:="Macro_add_to_contents", section:="everything", _ key:="number_of_calls", Default:=-1) number_of_calls = number_of_calls + 1 On Error Resume Next Call SaveSetting(appname:="Macro_add_to_contents", section:="everything", _ key:="number_of_calls", setting:=number_of_calls) On Error GoTo 0 If number_of_calls Mod 200 = 0 Then Call MsgBox("Hello! Now you have used this macro " & number_of_calls & " times. If you use it for non-commercial purposes, do not worry and click away this message. BUT if you use it for any COMMERCIAL PURPOSE, please note the license conditions and consider to order a version without this ugly message. (www.edv-abmayr.de/kontakt/kontakt.htm)", _ vbOKOnly, "Macro add_to_contents") End If End Sub Sub extract_adr_string(ByVal adr As String, _ ByRef row As Long, ByRef col As Long, _ Optional ByRef ws_name As String = "", _ Optional ByRef wb_name As String = "") ' The input string must be an address string, e.g.: ' A7 ' AX$44 ' Contents!$B4 ' [Pendel.xls]Nahrungsmittel!R5 ' =Mary!$C$3 (this we get from worksheet.name.value) ' ='Text-Muster'!$E$4 (the ws-name is enclose in single quotes as it contains a special character) ' ++++++ ' This procedure analyzes the input address string. ' If there is a valid workbook -name, it is returned in wb_name, else input is not changed ' If there is a valid worksheet-name, it is returned in ws_name, else input is not changed ' If there is a valid column name, the column number is returned in col, else 0 is returned ' If there is a valid row name, the row number is returned in col, else 0 is returned Dim line As String Dim pos1, pos2, pos3 As Integer ' positions in string '-------------------------------------------------------------------------- ' Extract data from the input address string line = adr line = Replace(line, "$", "") line = Replace(line, "'", "") If Left(line, 1) = "=" Then line = Mid(line, 2) ' ------------ 1) workbook name pos1 = InStr(line, "[") pos2 = InStr(line, "]") If pos1 > 0 And pos2 > 0 Then wb_name = Mid(line, pos1 + 1, pos2 - pos1 - 1) Else pos2 = 0 ' for searching ws-name End If ' ------------ 2) worksheet name pos3 = InStr(pos2 + 1, line, "!") If pos3 > 1 Then ws_name = Mid(line, pos2 + 1, pos3 - pos2 - 1) ElseIf pos3 = 1 Then ' only "!" means: use actual ws -> we do nothing as we do not know its name Else ' worksheet name not supplied pos3 = 0 End If ' ------------ 3) column col = 0 pos3 = pos3 + 1 While is_letter_Latin(Mid(line, pos3, 1)) <> 0 If is_letter_Latin(Mid(line, pos3, 1)) = 1 Then col = (col * 26) + Asc(Mid(line, pos3, 1)) - Asc("A") + 1 Else col = (col * 26) + Asc(Mid(line, pos3, 1)) - Asc("a") + 1 End If pos3 = pos3 + 1 Wend ' ------------ 4) row row = 0 While IsNumeric(Mid(line, pos3, 1)) row = (row * 10) + Asc(Mid(line, pos3, 1)) - Asc("0") pos3 = pos3 + 1 Wend End Sub Public Function find_worksheet(ByRef ws As Worksheet, ByVal name As String, _ ByVal generate_if_not_existing As Boolean, _ ByVal message_if_not_existing As Boolean, _ Optional ByVal wb As Variant) As Boolean ' look for the worksheet with name in the opened workbook wb (default is ActiveWorkbook) ' (optional arguments must be of type Variant, else IsMissing() does not work) ' If found: return it in ws ' Else : generate it, if generate_if_not_existing = true ' make a message box if message_if_not_existing (for the cases of ' generation or not there are two different messages!) ' RESULT = true, if ws was found or generated (so ws can be used) ' =false, if ws cannot be used ' If IsMissing(wb) Then Set wb = ActiveWorkbook End If find_worksheet = False ' Flag that tells whether the desired WS was found For Each ws In wb.Worksheets If ws.name = name Then find_worksheet = True Exit Function End If Next ws ' worksheet not found If generate_if_not_existing = True Then Set ws = wb.Worksheets.Add ws.name = name find_worksheet = True End If If message_if_not_existing = True Then If find_worksheet = False Then MsgBox ("Worksheet " & name & " was not found in workbook " & wb.name) Else MsgBox ("Worksheet " & name & " was generated in workbook " & wb.name) End If End If End Function Function is_letter_Latin(ByVal letter As String) As Integer ' The function checks only the first character of the input string and returns ' 1: for upper case Latin letter (A-Z) '-1: for lower case Latin letter (a-z) ' 0: else Dim b As String is_letter_Latin = 0 If Len(letter) > 0 Then b = Left(letter, 1) If (b >= "A" And b <= "Z") Then is_letter_Latin = 1 ElseIf (b >= "a" And b <= "z") Then is_letter_Latin = -1 End If End If End Function Public Function is_content_name(ByVal any_name As String) As Integer ' Returns ' 1: if any_name matches "c_xxxxx", where all x are digits ' 2: if 1 is false, but any_name matches "c_" ' 0: else ' any_name may start with a worksheet-name. If a "!" is found, everything up to this ' character is simply cut away Dim help As String Dim pos As Integer help = any_name pos = InStrRev(help, "!") If pos > 0 Then help = Mid(help, pos + 1) End If If InStr(help, "c_") = 1 Then If Len(help) = 7 Then If is_digits_only(Mid(help, 3, 5)) Then is_content_name = 1 Else is_content_name = 2 End If Else is_content_name = 2 End If Else is_content_name = 0 End If End Function Public Function is_digits_only(ByVal test_string As String) As Boolean ' returns True , if all characters of test_string are digits from 0 to 9 ' False, else Dim pos As Integer is_digits_only = True For pos = 1 To Len(test_string) If InStr("0123456789", Mid(test_string, pos, 1)) < 1 Then is_digits_only = False Exit For End If Next pos End Function