XBRL Financial Statement Scanner (kostenlos)
Unser Excel basiertes Bilanzanalyse-Tool ermöglicht die automatisierte Berechnung von 18 ausgewählten Finanzkennzahlen anhand von Finanzberichten im XBRL-Format. Ganz konkret können Sie beliebig viele der über die US-Börsenaufsicht SEC veröffentlichen XBRL-Berichte auswerten und für schnelle Vergleiche nutzen.
Der XBRL Financial Statement Scanner hat viele Vorteile. Die Einbindung in Excel ermöglicht eine einfache Bedienung in wenigen übersichtlichen Schritten. In wenigen Sekunden können Sie Kenzahlen aus vier gängigen Bereichen (z.B. Bilanzstruktur, Mittelverwendung und -herkunft, Liquidität, Profitabilität) generieren. Da die Kennzahlenberechnung offen gelegt wird, können die Berechnungen nachvollzogen und je nach Bedarf in eigene Analysesheets eingebunden werden. Zur Verwendung müssen Sie lediglich die XBRL-Dateien im Zip-Format auf Ihrem Rechner lokal speichern. Hierzu können Sie übrigens auch unseren kostenlosen XBRL RSS Feed Reader nutzen.
Anleitung:
- 1. Speichern Sie zunächst die zu analysierenden XBRL-Berichte auf Ihrem Rechner lokal ab. Hierzu empfiehlt es sich unseren XBRL RSS Feed Reader zu verwenden, mit dem Sie XBRL-Filings über die Online-Plattform der US-Börsenaufsicht SEC großflächig im Zip-Format herunterladen können.
- 2. Öffnen Sie unseren XBRL Financial Statement Scanner und klicken Sie auf den Button "Start Scan!".
- 3. Wählen Sie im sich öffnenden Fenster den Speicherort der Zip-Datei mit XBRL-Filings aus und klicken Sie auf "Öffnen".
- 4. Es öffnet sich ein weiteres Fenster, in dem Sie aufgefordert werden, einen lokalen Speicherort (z.B. "D:\Analyse\Unzip") zu definieren. In diesen Ordner werden die einzelnen XBRL-Dateien aus der Zip-Datei extrahiert.
- 5. Nach Auswahl des Speicherortes startet der Analyseprozess. Die einzelnen XBRL-Dateien werden ausgelesen, die primären Rechenwerke (z.B. Bilanz, Gewinn- und Verlustrechnung) zusammengesetzt und auf dieser Basis die 18 typisierten Bilanzkennzahlen automatisiert berechnet.
Installationshinweis:
Um das VBA-Makro vollumfänglich nutzen zu können, ist es notwendig, die Objektbibliothek "Microsoft XML" zu aktivieren. Hierzu müssen Sie zunächst in der Registerkarte "Entwicklertools" in das Visual Basic-Projektfenster wechseln. Über das Navigationsmenü "Extras" gelangen Sie dann in die Rubrik "Verweise", in der die Objektbibliothek ausgewählt und durch das Setzen eines Häckchens aktiviert werden kann. Sofern die Registerkarte "Entwicklertools" im Menüband nicht angezeigt wird, finden Sie hier eine Anleitung, wie Sie diese dauerhaft hinzufügen können.
Download XBRL Financial Statement Scanner (xlsm-File, 213KB)
(Version: 1.0, 2019)
VBA-Quellcode
Das von uns entwickelte XBRL Analyse-Tool besteht aus 5 Teilmodulen, die jeweils über die Entwickungsumgebung im Visual Basic-Projektfenster abgerufen werden können.
Public Sub XBRL_Processor() Dim objShellApp As Object Dim varFname As Variant varFname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=True) Dim varUnzipFolder As Variant Dim strUnzipFolderPath As String Dim i As Long intDocTypeTest = 0 If IsArray(varFname) = False Then Else strUnzipFolderPath = GetFolder("Create Folder to Unzip Files") strUnzipFolderPath2 = strUnzipFolderPath & "\" & "Unzip" MkDir strUnzipFolderPath2 Set objShellApp = CreateObject("Shell.Application") For i = LBound(varFname) To UBound(varFname) On Error Resume Next intFilingType = 0 Dim strFnameZip() As String strFnameZip() = Split(varFname(i), "\") Size = UBound(strFnameZip) strFnameZip2 = strFnameZip(Size) ' Exclusion of Bad Files (e.g., file size too big, error zip file) If strFnameZip2 <> "0001193125-14-124283-xbrl.zip" And strFnameZip2 <> "0001144204-15-038990-xbrl.zip" And strFnameZip2 <> "0001193125-13-136829-xbrl.zip" And strFnameZip2 <> "0000749251-16-000034-xbrl.zip" And strFnameZip2 <> "0001411342-16-000114-xbrl.zip" Then varUnzipFolder = strUnzipFolderPath2 & "\" & strFnameZip2 & "\" MkDir varUnzipFolder objShellApp.Namespace(varUnzipFolder).CopyHere objShellApp.Namespace(varFname(i)).items Dim varFileInstance As Variant Dim strFileTypeInstance As String strFileTypeInstance = "*.xml" varFileInstance = Dir(varUnzipFolder & strFileTypeInstance) Do While varFileInstance <> "" If varFileInstance <> "defnref.xml" And Not varFileInstance Like "*_*.xml" Then Dim xmlDocInstance As MSXML2.DOMDocument Set xmlDocInstance = New MSXML2.DOMDocument xmlDocInstance.async = False xmlDocInstance.validateOnParse = True xmlDocInstance.Load (varUnzipFolder & varFileInstance) ' Get Primary CIK Dim PrimaryCIKList As MSXML2.IXMLDOMNodeList Dim PrimaryCIKA As MSXML2.IXMLDOMNodeList Set PrimaryCIKA = xmlDocInstance.getElementsByTagName("identifier") Dim PrimaryCIKB As MSXML2.IXMLDOMNodeList Set PrimaryCIKB = xmlDocInstance.getElementsByTagName("xbrli:identifier") Dim PrimaryCIK As Object If PrimaryCIKA.Length > 0 Then Set PrimaryCIKList = xmlDocInstance.getElementsByTagName("identifier") End If If PrimaryCIKB.Length > 0 Then Set PrimaryCIKList = xmlDocInstance.getElementsByTagName("xbrli:identifier") End If intPrimaryCIK = 0 For Each PrimaryCIK In PrimaryCIKList intPrimaryCIK = intPrimaryCIK + 1 If intPrimaryCIK = 1 Then Dim NodeCIK As MSXML2.IXMLDOMNodeList Set NodeCIK = xmlDocInstance.getElementsByTagName("dei:EntityCentralIndexKey") Dim CIK As Object For Each CIK In NodeCIK If PrimaryCIK.Text = CIK.Text Then For Each CIKAttribute In CIK.Attributes If CIKAttribute.Name = "contextRef" Then 'Get Document Type Dim DocumentTypeNode As MSXML2.IXMLDOMNodeList Set DocumentTypeNode = xmlDocInstance.getElementsByTagName("dei:DocumentType") Dim DocumentType As Object For Each DocumentType In DocumentTypeNode For Each DocumentTypeAttribute In DocumentType.Attributes If DocumentTypeAttribute.Name = "contextRef" Then If (DocumentTypeAttribute.Text = CIKAttribute.Text And DocumentType.Text = "10-K") Or (DocumentTypeAttribute.Text = CIKAttribute.Text And DocumentType.Text = "10-K/A") Then intDocTypeTest = 1 Tabelle1.Cells(19, 2).ClearContents Tabelle1.Cells(19, 3).ClearContents Tabelle1.Cells(19, 4).ClearContents Tabelle1.Cells(19, 5).ClearContents Tabelle1.Cells(19, 6).ClearContents Tabelle1.Cells(21, 2).ClearContents Tabelle1.Cells(21, 3).ClearContents Tabelle1.Cells(21, 4).ClearContents Tabelle1.Cells(21, 5).ClearContents Tabelle1.Cells(21, 6).ClearContents Sheets("BS").Cells.ClearContents Sheets("IS").Cells.ClearContents Sheets("CI").Cells.ClearContents Sheets("CF").Cells.ClearContents intFilingType = 1 Tabelle1.Cells(19, "B").Value = Right(varFname(i), Len(varFname(i)) - InStr(varFname(i), "\0")) Tabelle1.Cells(19, "C").Value = varFileInstance Tabelle1.Cells(21, "B").Value = DocumentType.Text Tabelle1.Cells(19, "E").Value = CIK.Text Dim EntityNameNode As MSXML2.IXMLDOMNodeList Set EntityNameNode = xmlDocInstance.getElementsByTagName("dei:EntityRegistrantName") Dim EntityName As Object For Each EntityName In EntityNameNode For Each EntityNameAttribute In EntityName.Attributes If EntityNameAttribute.Name = "contextRef" Then If DocumentTypeAttribute.Text = EntityNameAttribute.Text Then Tabelle1.Cells(19, "D").Value = EntityName.Text End If End If Next EntityNameAttribute Next EntityName intFiscalPeriod = 0 Dim NodeFiscalPeriod As MSXML2.IXMLDOMNodeList Set NodeFiscalPeriod = xmlDocInstance.getElementsByTagName("dei:DocumentFiscalPeriodFocus") Dim FiscalPeriod As Object For Each FiscalPeriod In NodeFiscalPeriod For Each FiscalPeriodAttribute In FiscalPeriod.Attributes If FiscalPeriodAttribute.Name = "contextRef" Then If DocumentTypeAttribute.Text = FiscalPeriodAttribute.Text Then intFiscalPeriod = intFiscalPeriod + 1 Tabelle1.Cells(21, "C").Value = FiscalPeriod.Text End If End If Next FiscalPeriodAttribute Next FiscalPeriod If intFiscalPeriod = 0 Then Tabelle1.Cells(21, "C").Value = "-" End If intFiscalYear = 0 Dim NodeFiscalYear As MSXML2.IXMLDOMNodeList Set NodeFiscalYear = xmlDocInstance.getElementsByTagName("dei:DocumentFiscalYearFocus") Dim FiscalYear As Object For Each FiscalYear In NodeFiscalYear For Each FiscalYearAttribute In FiscalYear.Attributes If FiscalYearAttribute.Name = "contextRef" Then If DocumentTypeAttribute.Text = FiscalYearAttribute.Text Then intFiscalYear = intFiscalYear + 1 Tabelle1.Cells(21, "D").Value = FiscalYear.Text End If End If Next FiscalYearAttribute Next FiscalYear If intFiscalYear = 0 Then Tabelle1.Cells(21, "D").Value = "-" End If intEndDate = 0 Dim NodeEndDate As MSXML2.IXMLDOMNodeList Set NodeEndDate = xmlDocInstance.getElementsByTagName("dei:DocumentPeriodEndDate") Dim EndDate As Object For Each EndDate In NodeEndDate For Each EndDateAttribute In EndDate.Attributes If EndDateAttribute.Name = "contextRef" Then If DocumentTypeAttribute.Text = EndDateAttribute.Text Then intEndDate = intEndDate + 1 Tabelle1.Cells(21, "E").Value = EndDate.Text End If End If Next EndDateAttribute Next EndDate If intEndDate = 0 Then Tabelle1.Cells(21, "E").Value = "-" End If intFiler = 0 Dim NodeFiler As MSXML2.IXMLDOMNodeList Set NodeFiler = xmlDocInstance.getElementsByTagName("dei:EntityFilerCategory") Dim Filer As Object For Each Filer In NodeFiler For Each FilerAttribute In Filer.Attributes If FilerAttribute.Name = "contextRef" Then If DocumentTypeAttribute.Text = FilerAttribute.Text Then intFiler = intFiler + 1 Tabelle1.Cells(19, "F").Value = Filer.Text End If End If Next FilerAttribute Next Filer If intFiler = 0 Then Tabelle1.Cells(19, "F").Value = "-" End If intAmendmentFlag = 0 Dim NodeAmendmentFlag As MSXML2.IXMLDOMNodeList Set NodeAmendmentFlag = xmlDocInstance.getElementsByTagName("dei:AmendmentFlag") Dim AmendmentFlag As Object For Each AmendmentFlag In NodeAmendmentFlag For Each AmendmentFlagAttribute In AmendmentFlag.Attributes If AmendmentFlagAttribute.Name = "contextRef" Then If DocumentTypeAttribute.Text = AmendmentFlagAttribute.Text Then intAmendmentFlag = intAmendmentFlag + 1 Tabelle1.Cells(21, "F").Value = AmendmentFlag.Text End If End If Next AmendmentFlagAttribute Next AmendmentFlag If intAmendmentFlag = 0 Then Tabelle1.Cells(21, "F").Value = "-" End If End If End If Next Next End If Next CIKAttribute End If Next CIK End If Next If intFilingType = 1 Then ' EXTRACT LINE ITEMS INSTANCE (XML) Dim ndlstXbrl As MSXML2.IXMLDOMNodeList Set ndlstXbrl = xmlDocInstance.SelectNodes("//xbrl/*") Dim ndlstXbrli As MSXML2.IXMLDOMNodeList Set ndlstXbrli = xmlDocInstance.SelectNodes("//xbrli:xbrl/*") Dim LineItemList As MSXML2.IXMLDOMNodeList If ndlstXbrl.Length > 0 Then Set LineItemList = xmlDocInstance.SelectNodes("//xbrl/*") End If If ndlstXbrli.Length > 0 Then Set LineItemList = xmlDocInstance.SelectNodes("//xbrli:xbrl/*") End If Dim LineItem As MSXML2.IXMLDOMNode Dim arrGAAP As Variant ReDim arrGAAP(1 To LineItemList.Length + 1, 1 To 26) As Variant x = 0 For Each LineItem In LineItemList x = x + 1 If LineItem.Text <> "" Then arrGAAP(x, 1) = LineItem.nodeName arrGAAP(x, 2) = LineItem.Text For Each LineItemAttribute In LineItem.Attributes If LineItemAttribute.Name = "contextRef" Then arrGAAP(x, 3) = LineItemAttribute.Text End If If LineItemAttribute.Name = "unitRef" Then arrGAAP(x, 4) = LineItemAttribute.Text End If If LineItemAttribute.Name = "decimals" Then arrGAAP(x, 5) = LineItemAttribute.Text End If If LineItemAttribute.Name = "id" Then arrGAAP(x, 6) = LineItemAttribute.Text End If Next End If Next LineItem ' EXTRACT CONTEXT (XML) Dim ContextNodeList As MSXML2.IXMLDOMNodeList Dim ContextNodeListA As MSXML2.IXMLDOMNodeList Set ContextNodeListA = xmlDocInstance.SelectNodes("//context") Dim ContextNodeListB As MSXML2.IXMLDOMNodeList Set ContextNodeListB = xmlDocInstance.SelectNodes("//xbrli:context") If ContextNodeListA.Length > 0 Then Set ContextNodeList = xmlDocInstance.SelectNodes("//context") End If If ContextNodeListB.Length > 0 Then Set ContextNodeList = xmlDocInstance.SelectNodes("//xbrli:context") End If Dim ContextItem As MSXML2.IXMLDOMNode Dim arrContextList As Variant ReDim arrContextList(1 To ContextNodeList.Length, 1 To 16) As Variant x = 0 For Each ContextItem In ContextNodeList x = x + 1 y = 0 For Each ContextItemAttribute In ContextItem.Attributes If ContextItemAttribute.Name = "id" Then arrContextList(x, 1) = ContextItem.nodeName arrContextList(x, 2) = ContextItemAttribute.Text For Each ContextItemChild In ContextItem.ChildNodes If ContextItemChild.nodeName = "entity" Or ContextItemChild.nodeName = "xbrli:entity" Then For Each ContextItemChild2 In ContextItemChild.ChildNodes If ContextItemChild2.nodeName = "identifier" Or ContextItemChild2.nodeName = "xbrli:identifier" Then arrContextList(x, 3) = ContextItemChild2.Text End If If ContextItemChild2.nodeName = "segment" Or ContextItemChild2.nodeName = "xbrli:segment" Then For Each ContextItemChild3 In ContextItemChild2.ChildNodes y = y + 1 For Each ContextItemChild3Attribute In ContextItemChild3.Attributes If ContextItemChild3Attribute.Name = "dimension" And y = 1 Then arrContextList(x, 4) = ContextItemChild3Attribute.Text arrContextList(x, 5) = ContextItemChild3.Text End If If ContextItemChild3Attribute.Name = "dimension" And y = 2 Then arrContextList(x, 6) = ContextItemChild3Attribute.Text arrContextList(x, 7) = ContextItemChild3.Text End If If ContextItemChild3Attribute.Name = "dimension" And y = 3 Then arrContextList(x, 8) = ContextItemChild3Attribute.Text arrContextList(x, 9) = ContextItemChild3.Text End If If ContextItemChild3Attribute.Name = "dimension" And y = 4 Then arrContextList(x, 10) = ContextItemChild3Attribute.Text arrContextList(x, 11) = ContextItemChild3.Text End If If ContextItemChild3Attribute.Name = "dimension" And y = 5 Then arrContextList(x, 12) = ContextItemChild3Attribute.Text arrContextList(x, 13) = ContextItemChild3.Text End If Next ContextItemChild3Attribute Next ContextItemChild3 End If Next ContextItemChild2 End If If ContextItemChild.nodeName = "period" Or ContextItemChild.nodeName = "xbrli:period" Then For Each ContextItemChild2 In ContextItemChild.ChildNodes If ContextItemChild2.nodeName = "instant" Or ContextItemChild2.nodeName = "xbrli:instant" Then arrContextList(x, 14) = ContextItemChild2.Text End If If ContextItemChild2.nodeName = "startDate" Or ContextItemChild2.nodeName = "xbrli:startDate" Then arrContextList(x, 15) = ContextItemChild2.Text End If If ContextItemChild2.nodeName = "endDate" Or ContextItemChild2.nodeName = "xbrli:endDate" Then arrContextList(x, 16) = ContextItemChild2.Text End If Next ContextItemChild2 End If Next ContextItemChild End If Next ContextItemAttribute Next ContextItem ' EXTRACT UNIT (XML) Dim UnitNodeList As MSXML2.IXMLDOMNodeList Dim UnitNodeListA As MSXML2.IXMLDOMNodeList Set UnitNodeListA = xmlDocInstance.SelectNodes("//unit") Dim UnitNodeListB As MSXML2.IXMLDOMNodeList Set UnitNodeListB = xmlDocInstance.SelectNodes("//xbrli:unit") If UnitNodeListA.Length > 0 Then Set UnitNodeList = xmlDocInstance.SelectNodes("//unit") End If If ContextNodeListB.Length > 0 Then Set UnitNodeList = xmlDocInstance.SelectNodes("//xbrli:unit") End If Dim UnitItem As MSXML2.IXMLDOMNode Dim UnitList As Variant ReDim UnitList(1 To UnitNodeList.Length, 1 To 5) As Variant x = 0 For Each UnitItem In UnitNodeList x = x + 1 For Each UnitItemAttribute In UnitItem.Attributes If UnitItemAttribute.Name = "id" Then UnitList(x, 1) = UnitItem.nodeName UnitList(x, 2) = UnitItemAttribute.Text For Each UnitItemChild In UnitItem.ChildNodes If UnitItemChild.nodeName = "measure" Or UnitItemChild.nodeName = "xbrli:measure" Then UnitList(x, 3) = UnitItemChild.Text End If If UnitItemChild.nodeName = "divide" Or UnitItemChild.nodeName = "xbrli:divide" Then For Each UnitItemChild2 In UnitItemChild.ChildNodes If UnitItemChild2.nodeName = "unitNumerator" Or UnitItemChild2.nodeName = "xbrli:unitNumerator" Then For Each UnitItemChild3 In UnitItemChild2.ChildNodes If UnitItemChild3.nodeName = "measure" Or UnitItemChild3.nodeName = "xbrli:measure" Then UnitList(x, 4) = UnitItemChild3.Text End If Next End If If UnitItemChild2.nodeName = "unitDenominator" Or UnitItemChild2.nodeName = "xbrli:unitDenominator" Then For Each UnitItemChild3 In UnitItemChild2.ChildNodes If UnitItemChild3.nodeName = "measure" Or UnitItemChild3.nodeName = "xbrli:measure" Then UnitList(x, 5) = UnitItemChild3.Text End If Next End If Next End If Next End If Next Next ' Combine Line Items & Context & Unit For x = LBound(arrGAAP) To UBound(arrGAAP) For y = LBound(arrContextList) To UBound(arrContextList) If arrGAAP(x, 3) = arrContextList(y, 2) Then arrGAAP(x, 7) = arrContextList(y, 2) arrGAAP(x, 8) = arrContextList(y, 3) arrGAAP(x, 9) = arrContextList(y, 4) arrGAAP(x, 10) = arrContextList(y, 5) arrGAAP(x, 11) = arrContextList(y, 6) arrGAAP(x, 12) = arrContextList(y, 7) arrGAAP(x, 13) = arrContextList(y, 8) arrGAAP(x, 14) = arrContextList(y, 9) arrGAAP(x, 15) = arrContextList(y, 10) arrGAAP(x, 16) = arrContextList(y, 11) arrGAAP(x, 17) = arrContextList(y, 12) arrGAAP(x, 18) = arrContextList(y, 13) arrGAAP(x, 19) = arrContextList(y, 14) arrGAAP(x, 20) = arrContextList(y, 15) arrGAAP(x, 21) = arrContextList(y, 16) End If Next y For y = LBound(UnitList) To UBound(UnitList) If arrGAAP(x, 4) = UnitList(y, 2) Then arrGAAP(x, 22) = UnitList(y, 1) arrGAAP(x, 23) = UnitList(y, 2) arrGAAP(x, 24) = UnitList(y, 3) arrGAAP(x, 25) = UnitList(y, 4) arrGAAP(x, 26) = UnitList(y, 5) End If Next y Next x ' EXTRACT LABELLINKBASE Dim varFileLabel As Variant Dim strFileTypeLabel As String strFileTypeLabel = "*_lab.xml" varFileLabel = Dir(varUnzipFolder & strFileTypeLabel) Dim xmlDocLabel As MSXML2.DOMDocument Set xmlDocLabel = New MSXML2.DOMDocument xmlDocLabel.async = False xmlDocLabel.validateOnParse = True xmlDocLabel.Load (varUnzipFolder & varFileLabel) Dim LabelLink As Object Dim NodeLabelLinks As MSXML2.IXMLDOMNodeList Dim NodeLabelLinksA As MSXML2.IXMLDOMNodeList Set NodeLabelLinksA = xmlDocLabel.SelectNodes("//labelLink") Dim NodeLabelLinksB As MSXML2.IXMLDOMNodeList Set NodeLabelLinksB = xmlDocLabel.SelectNodes("//link:labelLink") Dim NodeLabelLinksLocA As MSXML2.IXMLDOMNodeList Set NodeLabelLinksLocA = xmlDocLabel.SelectNodes("//labelLink/loc") Dim NodeLabelLinksLocB As MSXML2.IXMLDOMNodeList Set NodeLabelLinksLocB = xmlDocLabel.SelectNodes("//link:labelLink/link:loc") Dim NodeLabelLinksLocC As MSXML2.IXMLDOMNodeList Set NodeLabelLinksLocC = xmlDocLabel.SelectNodes("//link:labelLink/loc") If NodeLabelLinksA.Length > 0 Then Set NodeLabelLinks = xmlDocLabel.SelectNodes("//labelLink") End If If NodeLabelLinksB.Length > 0 Then Set NodeLabelLinks = xmlDocLabel.SelectNodes("//link:labelLink") End If If NodeLabelLinksLocA.Length > 0 Then Set NodeLabelLinksLoc = xmlDocLabel.SelectNodes("//labelLink/loc") Set NodeLabelLinksLabel = xmlDocLabel.SelectNodes("//labelLink/label") Set NodeLabelLinksLabelArc = xmlDocLabel.SelectNodes("//labelLink/labelArc") End If If NodeLabelLinksLocB.Length > 0 Then Set NodeLabelLinksLoc = xmlDocLabel.SelectNodes("//link:labelLink/link:loc") Set NodeLabelLinksLabel = xmlDocLabel.SelectNodes("//link:labelLink/link:label") Set NodeLabelLinksLabelArc = xmlDocLabel.SelectNodes("//link:labelLink/link:labelArc") End If If NodeLabelLinksLocC.Length > 0 Then Set NodeLabelLinksLoc = xmlDocLabel.SelectNodes("//link:labelLink/loc") Set NodeLabelLinksLabel = xmlDocLabel.SelectNodes("//link:labelLink/label") Set NodeLabelLinksLabelArc = xmlDocLabel.SelectNodes("//link:labelLink/labelArc") End If ReDim arrLabelLoc(1 To NodeLabelLinksLoc.Length, 1 To 4) As Variant ReDim arrLabel(1 To NodeLabelLinksLabel.Length, 1 To 5) As Variant ReDim arrLabelArc(1 To NodeLabelLinksLabelArc.Length, 1 To 5) As Variant intLabLoc = 0 intLabArc = 0 intLab = 0 For Each LabelLink In NodeLabelLinks For Each LabelLinkAttribute In LabelLink.Attributes If LabelLinkAttribute.Name = "xlink:role" Then For Each LabelLinkChild In LabelLink.ChildNodes If LabelLinkChild.nodeName = "loc" Or LabelLinkChild.nodeName = "link:loc" Then intLabLoc = intLabLoc + 1 arrLabelLoc(intLabLoc, 1) = LabelLinkAttribute.Text arrLabelLoc(intLabLoc, 2) = LabelLinkChild.nodeName For Each LabelLinkChildAttribute In LabelLinkChild.Attributes If LabelLinkChildAttribute.Name = "xlink:href" Then arrLabelLoc(intLabLoc, 3) = Right(LabelLinkChildAttribute.Text, Len(LabelLinkChildAttribute.Text) - InStrRev(LabelLinkChildAttribute.Text, "#", , vbTextCompare)) End If If LabelLinkChildAttribute.Name = "xlink:label" Then arrLabelLoc(intLabLoc, 4) = LabelLinkChildAttribute.Text End If Next End If If LabelLinkChild.nodeName = "label" Or LabelLinkChild.nodeName = "link:label" Then intLab = intLab + 1 arrLabel(intLab, 1) = LabelLinkAttribute.Text arrLabel(intLab, 2) = LabelLinkChild.nodeName For Each LabelLinkChildAttribute In LabelLinkChild.Attributes If LabelLinkChildAttribute.Name = "xlink:label" Then arrLabel(intLab, 3) = LabelLinkChildAttribute.Text End If If LabelLinkChildAttribute.Name = "xlink:role" Then arrLabel(intLab, 4) = LabelLinkChildAttribute.Text End If Next arrLabel(intLab, 5) = LabelLinkChild.Text End If If LabelLinkChild.nodeName = "labelArc" Or LabelLinkChild.nodeName = "link:labelArc" Then intLabArc = intLabArc + 1 arrLabelArc(intLabArc, 1) = LabelLinkAttribute.Text arrLabelArc(intLabArc, 2) = LabelLinkChild.nodeName For Each LabelLinkChildAttribute In LabelLinkChild.Attributes If LabelLinkChildAttribute.Name = "xlink:from" Then arrLabelArc(intLabArc, 3) = LabelLinkChildAttribute.Text End If If LabelLinkChildAttribute.Name = "xlink:to" Then arrLabelArc(intLabArc, 4) = LabelLinkChildAttribute.Text End If If LabelLinkChildAttribute.Name = "xlink:arcrole" Then arrLabelArc(intLabArc, 5) = LabelLinkChildAttribute.Text End If Next End If Next End If Next LabelLinkAttribute Next LabelLink ReDim arrLabelList(1 To UBound(arrLabel), 1 To 10) As Variant x = 0 For y = LBound(arrLabel) To UBound(arrLabel) For Z = LBound(arrLabelArc) To UBound(arrLabelArc) If arrLabel(y, 3) = arrLabelArc(Z, 4) Then x = x + 1 arrLabelList(x, 1) = arrLabel(y, 1) arrLabelList(x, 2) = arrLabel(y, 2) arrLabelList(x, 3) = arrLabel(y, 3) arrLabelList(x, 4) = arrLabel(y, 4) arrLabelList(x, 5) = arrLabel(y, 5) arrLabelList(x, 6) = arrLabelArc(Z, 3) arrLabelList(x, 7) = arrLabelArc(Z, 4) arrLabelList(x, 8) = arrLabelArc(Z, 5) End If Next Z Next y For y = LBound(arrLabelList) To UBound(arrLabelList) For Z = LBound(arrLabelLoc) To UBound(arrLabelLoc) If arrLabelList(y, 6) = arrLabelLoc(Z, 4) Then arrLabelList(y, 9) = arrLabelLoc(Z, 3) arrLabelList(y, 10) = arrLabelLoc(Z, 4) End If Next Z Next y ' EXTRACT APPINFO (XSD) Dim varFileSchema As Variant Dim strFileTypeSchema As String strFileTypeSchema = "*.xsd" varFileSchema = Dir(varUnzipFolder & strFileTypeSchema) Dim xmlDocSchema As MSXML2.DOMDocument Set xmlDocSchema = New MSXML2.DOMDocument xmlDocSchema.async = False xmlDocSchema.validateOnParse = True xmlDocSchema.Load (varUnzipFolder & varFileSchema) Dim AppInfos As MSXML2.IXMLDOMNodeList Dim AppInfo As Object Set AppInfos = xmlDocSchema.SelectNodes("//link:roleType") ReDim arrAppRoles(1 To AppInfos.Length, 1 To 2) As Variant a = 0 For Each AppInfo In AppInfos For Each AppInfoAttribute In AppInfo.Attributes If AppInfoAttribute.Name = "roleURI" Then a = a + 1 arrAppRoles(a, 1) = AppInfoAttribute.Text For Each AppInfoChild In AppInfo.ChildNodes If AppInfoChild.nodeName = "link:definition" Then arrAppRoles(a, 2) = AppInfoChild.Text End If Next AppInfoChild End If Next AppInfoAttribute Next AppInfo Sort2dm arrAppRoles, 2, xlAscending intRole = 0 For intRole2 = LBound(arrAppRoles) To UBound(arrAppRoles) intRole = intRole + 1 strStatement = StrConv(arrAppRoles(intRole2, 2), vbLowerCase) If intRole < 14 Then If strStatement Like "*statement*" And Not strStatement Like "*thetical*" And Not strStatement Like "*disclosure*" And Not strStatement Like "*(detail)*" And Not strStatement Like "*equity*" And Not strStatement Like "*compensation*" Then intStatementTest = 0 If strStatement Like "*balance*sheet*" Or strStatement Like "*financial*position*" Or strStatement Like "*condition*" Then intStatementTest = 1 End If If (strStatement Like "*income*" Or strStatement Like "*operation*" Or strStatement Like "*earnings*") And Not strStatement Like "*comprehensive*" And Not strStatement Like "*nature*" Then intStatementTest = 1 End If If strStatement Like "*comprehensive*" And Not strStatement Like "*equity*" Then intStatementTest = 1 End If If strStatement Like "*cash*flow*" Then intStatementTest = 1 End If If intStatementTest > 0 Then ' EXTRACT DEFINITIONLINKBASE Dim varFileDef As Variant Dim strFileTypeDef As String strFileTypeDef = "*_def.xml" varFileDef = Dir(varUnzipFolder & strFileTypeDef) Dim xmlDocDef As MSXML2.DOMDocument Set xmlDocDef = New MSXML2.DOMDocument xmlDocDef.async = False xmlDocDef.validateOnParse = True xmlDocDef.Load (varUnzipFolder & varFileDef) Dim NodeDefLinks As MSXML2.IXMLDOMNodeList Dim NodeDefLinks2 As MSXML2.IXMLDOMNodeList Dim DefLink As Object Dim NodeDefLinksA As MSXML2.IXMLDOMNodeList Set NodeDefLinksA = xmlDocDef.SelectNodes("//definitionLink") Dim NodeDefLinksB As MSXML2.IXMLDOMNodeList Set NodeDefLinksB = xmlDocDef.SelectNodes("//link:definitionLink") If NodeDefLinksA.Length > 0 Then Set NodeDefLinks = xmlDocDef.SelectNodes("//definitionLink") Set NodeDefLinks2 = xmlDocDef.SelectNodes("//definitionLink/definitionArc") End If If NodeDefLinksB.Length > 0 Then Set NodeDefLinks = xmlDocDef.SelectNodes("//link:definitionLink") Set NodeDefLinks2 = xmlDocDef.SelectNodes("//link:definitionLink/link:definitionArc") End If ReDim arrDefList(1 To (NodeDefLinks2.Length), 1 To 8) As Variant r = 0 For Each DefLink In NodeDefLinks For Each DefLinkAttribute In DefLink.Attributes If DefLinkAttribute.Name = "xlink:role" Then If DefLinkAttribute.Text = arrAppRoles(intRole2, 1) Then intDefLocLength = 0 intDefArcLength = 0 For Each DefLinkChild In DefLink.ChildNodes If DefLinkChild.nodeName = "loc" Or DefLinkChild.nodeName = "link:loc" Then intDefLocLength = intDefLocLength + 1 End If If DefLinkChild.nodeName = "definitionArc" Or DefLinkChild.nodeName = "link:definitionArc" Then intDefArcLength = intDefArcLength + 1 End If Next If intDefLocLength > 0 And intDefArcLength > 0 Then ReDim arrDefLoc(1 To intDefLocLength, 1 To 4) As Variant ReDim arrDefArc(1 To intDefArcLength, 1 To 6) As Variant l = 0 a = 0 For Each DefLinkChild In DefLink.ChildNodes If DefLinkChild.nodeName = "loc" Or DefLinkChild.nodeName = "link:loc" Then l = l + 1 arrDefLoc(l, 1) = DefLinkAttribute.Text arrDefLoc(l, 2) = DefLinkChild.nodeName For Each DefLinkChildAttribute In DefLinkChild.Attributes If DefLinkChildAttribute.Name = "xlink:href" Then arrDefLoc(l, 3) = Right(DefLinkChildAttribute.Text, Len(DefLinkChildAttribute.Text) - InStrRev(DefLinkChildAttribute.Text, "#", , vbTextCompare)) End If If DefLinkChildAttribute.Name = "xlink:label" Then arrDefLoc(l, 4) = DefLinkChildAttribute.Text End If Next End If If DefLinkChild.nodeName = "definitionArc" Or DefLinkChild.nodeName = "link:definitionArc" Then a = a + 1 arrDefArc(a, 1) = DefLinkAttribute.Text arrDefArc(a, 2) = DefLinkChild.nodeName For Each DefLinkChildAttribute In DefLinkChild.Attributes If DefLinkChildAttribute.Name = "xlink:from" Then arrDefArc(a, 3) = DefLinkChildAttribute.Text End If If DefLinkChildAttribute.Name = "xlink:to" Then arrDefArc(a, 4) = DefLinkChildAttribute.Text End If If DefLinkChildAttribute.Name = "order" Then arrDefArc(a, 5) = Val(DefLinkChildAttribute.Text) End If If DefLinkChildAttribute.Name = "xlink:arcrole" Then arrDefArc(a, 6) = DefLinkChildAttribute.Text End If Next End If Next intNumberDefArcs = 0 For a = LBound(arrDefArc) To UBound(arrDefArc) intNumberDefArcs = intNumberDefArcs + 1 For l = LBound(arrDefLoc) To UBound(arrDefLoc) If arrDefLoc(l, 4) = arrDefArc(a, 3) Then arrDefArc(a, 3) = arrDefLoc(l, 3) End If If arrDefLoc(l, 4) = arrDefArc(a, 4) Then arrDefArc(a, 4) = arrDefLoc(l, 3) End If Next l Next a For a = LBound(arrDefArc) To UBound(arrDefArc) For b = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(a, 3) = arrDefArc(b, 3) And arrDefArc(a, 4) = arrDefArc(b, 4) Then intNumberDefArcs = intNumberDefArcs + 1 End If Next b Next a Sort2dm arrDefArc, 5, xlAscending ReDim arrDefList_temp(1 To intNumberDefArcs, 1 To 7) As Variant q = 0 For a = LBound(arrDefArc) To UBound(arrDefArc) Level = 0 For b = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(a, 3) = arrDefArc(b, 4) Then Level = Level + 1 End If Next b If Level = 0 Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(a, 1) arrDefList_temp(q, 2) = arrDefArc(a, 2) arrDefList_temp(q, 3) = arrDefArc(a, 3) arrDefList_temp(q, 4) = arrDefArc(a, 4) arrDefList_temp(q, 5) = arrDefArc(a, 5) arrDefList_temp(q, 6) = arrDefArc(a, 6) arrDefList_temp(q, 7) = 0 For c = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(c, 3) = arrDefArc(a, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(c, 1) arrDefList_temp(q, 2) = arrDefArc(c, 2) arrDefList_temp(q, 3) = arrDefArc(c, 3) arrDefList_temp(q, 4) = arrDefArc(c, 4) arrDefList_temp(q, 5) = arrDefArc(c, 5) arrDefList_temp(q, 6) = arrDefArc(c, 6) arrDefList_temp(q, 7) = 1 For d = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(d, 3) = arrDefArc(c, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(d, 1) arrDefList_temp(q, 2) = arrDefArc(d, 2) arrDefList_temp(q, 3) = arrDefArc(d, 3) arrDefList_temp(q, 4) = arrDefArc(d, 4) arrDefList_temp(q, 5) = arrDefArc(d, 5) arrDefList_temp(q, 6) = arrDefArc(d, 6) arrDefList_temp(q, 7) = 2 For e = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(e, 3) = arrDefArc(d, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(e, 1) arrDefList_temp(q, 2) = arrDefArc(e, 2) arrDefList_temp(q, 3) = arrDefArc(e, 3) arrDefList_temp(q, 4) = arrDefArc(e, 4) arrDefList_temp(q, 5) = arrDefArc(e, 5) arrDefList_temp(q, 6) = arrDefArc(e, 6) arrDefList_temp(q, 7) = 3 For f = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(f, 3) = arrDefArc(e, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(f, 1) arrDefList_temp(q, 2) = arrDefArc(f, 2) arrDefList_temp(q, 3) = arrDefArc(f, 3) arrDefList_temp(q, 4) = arrDefArc(f, 4) arrDefList_temp(q, 5) = arrDefArc(f, 5) arrDefList_temp(q, 6) = arrDefArc(f, 6) arrDefList_temp(q, 7) = 4 For g = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(g, 3) = arrDefArc(f, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(g, 1) arrDefList_temp(q, 2) = arrDefArc(g, 2) arrDefList_temp(q, 3) = arrDefArc(g, 3) arrDefList_temp(q, 4) = arrDefArc(g, 4) arrDefList_temp(q, 5) = arrDefArc(g, 5) arrDefList_temp(q, 6) = arrDefArc(g, 6) arrDefList_temp(q, 7) = 5 For h = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(h, 3) = arrDefArc(g, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(h, 1) arrDefList_temp(q, 2) = arrDefArc(h, 2) arrDefList_temp(q, 3) = arrDefArc(h, 3) arrDefList_temp(q, 4) = arrDefArc(h, 4) arrDefList_temp(q, 5) = arrDefArc(h, 5) arrDefList_temp(q, 6) = arrDefArc(h, 6) arrDefList_temp(q, 7) = 6 For k = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(k, 3) = arrDefArc(h, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(k, 1) arrDefList_temp(q, 2) = arrDefArc(k, 2) arrDefList_temp(q, 3) = arrDefArc(k, 3) arrDefList_temp(q, 4) = arrDefArc(k, 4) arrDefList_temp(q, 5) = arrDefArc(k, 5) arrDefList_temp(q, 6) = arrDefArc(k, 6) arrDefList_temp(q, 7) = 7 For l = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(l, 3) = arrDefArc(k, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(l, 1) arrDefList_temp(q, 2) = arrDefArc(l, 2) arrDefList_temp(q, 3) = arrDefArc(l, 3) arrDefList_temp(q, 4) = arrDefArc(l, 4) arrDefList_temp(q, 5) = arrDefArc(l, 5) arrDefList_temp(q, 6) = arrDefArc(l, 6) arrDefList_temp(q, 7) = 8 For m = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(m, 3) = arrDefArc(l, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(m, 1) arrDefList_temp(q, 2) = arrDefArc(m, 2) arrDefList_temp(q, 3) = arrDefArc(m, 3) arrDefList_temp(q, 4) = arrDefArc(m, 4) arrDefList_temp(q, 5) = arrDefArc(m, 5) arrDefList_temp(q, 6) = arrDefArc(m, 6) arrDefList_temp(q, 7) = 9 For n = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(n, 3) = arrDefArc(m, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(n, 1) arrDefList_temp(q, 2) = arrDefArc(n, 2) arrDefList_temp(q, 3) = arrDefArc(n, 3) arrDefList_temp(q, 4) = arrDefArc(n, 4) arrDefList_temp(q, 5) = arrDefArc(n, 5) arrDefList_temp(q, 6) = arrDefArc(n, 6) arrDefList_temp(q, 7) = 10 For o = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(o, 3) = arrDefArc(n, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(o, 1) arrDefList_temp(q, 2) = arrDefArc(o, 2) arrDefList_temp(q, 3) = arrDefArc(o, 3) arrDefList_temp(q, 4) = arrDefArc(o, 4) arrDefList_temp(q, 5) = arrDefArc(o, 5) arrDefList_temp(q, 6) = arrDefArc(o, 6) arrDefList_temp(q, 7) = 11 For p = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(p, 3) = arrDefArc(o, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(p, 1) arrDefList_temp(q, 2) = arrDefArc(p, 2) arrDefList_temp(q, 3) = arrDefArc(p, 3) arrDefList_temp(q, 4) = arrDefArc(p, 4) arrDefList_temp(q, 5) = arrDefArc(p, 5) arrDefList_temp(q, 6) = arrDefArc(p, 6) arrDefList_temp(q, 7) = 12 For r = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(r, 3) = arrDefArc(p, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(r, 1) arrDefList_temp(q, 2) = arrDefArc(r, 2) arrDefList_temp(q, 3) = arrDefArc(r, 3) arrDefList_temp(q, 4) = arrDefArc(r, 4) arrDefList_temp(q, 5) = arrDefArc(r, 5) arrDefList_temp(q, 6) = arrDefArc(r, 6) arrDefList_temp(q, 7) = 13 For s = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(s, 3) = arrDefArc(r, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(s, 1) arrDefList_temp(q, 2) = arrDefArc(s, 2) arrDefList_temp(q, 3) = arrDefArc(s, 3) arrDefList_temp(q, 4) = arrDefArc(s, 4) arrDefList_temp(q, 5) = arrDefArc(s, 5) arrDefList_temp(q, 6) = arrDefArc(s, 6) arrDefList_temp(q, 7) = 14 For t = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(t, 3) = arrDefArc(s, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(t, 1) arrDefList_temp(q, 2) = arrDefArc(t, 2) arrDefList_temp(q, 3) = arrDefArc(t, 3) arrDefList_temp(q, 4) = arrDefArc(t, 4) arrDefList_temp(q, 5) = arrDefArc(t, 5) arrDefList_temp(q, 6) = arrDefArc(t, 6) arrDefList_temp(q, 7) = 15 For u = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(u, 3) = arrDefArc(t, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(u, 1) arrDefList_temp(q, 2) = arrDefArc(u, 2) arrDefList_temp(q, 3) = arrDefArc(u, 3) arrDefList_temp(q, 4) = arrDefArc(u, 4) arrDefList_temp(q, 5) = arrDefArc(u, 5) arrDefList_temp(q, 6) = arrDefArc(u, 6) arrDefList_temp(q, 7) = 16 For v = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(v, 3) = arrDefArc(u, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(v, 1) arrDefList_temp(q, 2) = arrDefArc(v, 2) arrDefList_temp(q, 3) = arrDefArc(v, 3) arrDefList_temp(q, 4) = arrDefArc(v, 4) arrDefList_temp(q, 5) = arrDefArc(v, 5) arrDefList_temp(q, 6) = arrDefArc(v, 6) arrDefList_temp(q, 7) = 17 For Z = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(Z, 3) = arrDefArc(v, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(Z, 1) arrDefList_temp(q, 2) = arrDefArc(Z, 2) arrDefList_temp(q, 3) = arrDefArc(Z, 3) arrDefList_temp(q, 4) = arrDefArc(Z, 4) arrDefList_temp(q, 5) = arrDefArc(Z, 5) arrDefList_temp(q, 6) = arrDefArc(Z, 6) arrDefList_temp(q, 7) = 18 For za = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(za, 3) = arrDefArc(Z, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(za, 1) arrDefList_temp(q, 2) = arrDefArc(za, 2) arrDefList_temp(q, 3) = arrDefArc(za, 3) arrDefList_temp(q, 4) = arrDefArc(za, 4) arrDefList_temp(q, 5) = arrDefArc(za, 5) arrDefList_temp(q, 6) = arrDefArc(za, 6) arrDefList_temp(q, 7) = 19 For zb = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(zb, 3) = arrDefArc(za, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(zb, 1) arrDefList_temp(q, 2) = arrDefArc(zb, 2) arrDefList_temp(q, 3) = arrDefArc(zb, 3) arrDefList_temp(q, 4) = arrDefArc(zb, 4) arrDefList_temp(q, 5) = arrDefArc(zb, 5) arrDefList_temp(q, 6) = arrDefArc(zb, 6) arrDefList_temp(q, 7) = 20 For zc = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(zc, 3) = arrDefArc(zb, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(zc, 1) arrDefList_temp(q, 2) = arrDefArc(zc, 2) arrDefList_temp(q, 3) = arrDefArc(zc, 3) arrDefList_temp(q, 4) = arrDefArc(zc, 4) arrDefList_temp(q, 5) = arrDefArc(zc, 5) arrDefList_temp(q, 6) = arrDefArc(zc, 6) arrDefList_temp(q, 7) = 21 For zd = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(zd, 3) = arrDefArc(zc, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(zd, 1) arrDefList_temp(q, 2) = arrDefArc(zd, 2) arrDefList_temp(q, 3) = arrDefArc(zd, 3) arrDefList_temp(q, 4) = arrDefArc(zd, 4) arrDefList_temp(q, 5) = arrDefArc(zd, 5) arrDefList_temp(q, 6) = arrDefArc(zd, 6) arrDefList_temp(q, 7) = 22 For ze = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(ze, 3) = arrDefArc(zd, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(ze, 1) arrDefList_temp(q, 2) = arrDefArc(ze, 2) arrDefList_temp(q, 3) = arrDefArc(ze, 3) arrDefList_temp(q, 4) = arrDefArc(ze, 4) arrDefList_temp(q, 5) = arrDefArc(ze, 5) arrDefList_temp(q, 6) = arrDefArc(ze, 6) arrDefList_temp(q, 7) = 23 For zf = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(zf, 3) = arrDefArc(ze, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(zf, 1) arrDefList_temp(q, 2) = arrDefArc(zf, 2) arrDefList_temp(q, 3) = arrDefArc(zf, 3) arrDefList_temp(q, 4) = arrDefArc(zf, 4) arrDefList_temp(q, 5) = arrDefArc(zf, 5) arrDefList_temp(q, 6) = arrDefArc(zf, 6) arrDefList_temp(q, 7) = 24 For zg = LBound(arrDefArc) To UBound(arrDefArc) If arrDefArc(zg, 3) = arrDefArc(zf, 4) Then q = q + 1 arrDefList_temp(q, 1) = arrDefArc(zg, 1) arrDefList_temp(q, 2) = arrDefArc(zg, 2) arrDefList_temp(q, 3) = arrDefArc(zg, 3) arrDefList_temp(q, 4) = arrDefArc(zg, 4) arrDefList_temp(q, 5) = arrDefArc(zg, 5) arrDefList_temp(q, 6) = arrDefArc(zg, 6) arrDefList_temp(q, 7) = 25 End If Next zg End If Next zf End If Next ze End If Next zd End If Next zc End If Next zb End If Next za End If Next Z End If Next v End If Next u End If Next t End If Next s End If Next r End If Next p End If Next o End If Next n End If Next m End If Next l End If Next k End If Next h End If Next g End If Next f End If Next e End If Next d End If Next c End If Next a For a = LBound(arrDefList_temp) To UBound(arrDefList_temp) r = r + 1 arrDefList(r, 1) = arrDefList_temp(a, 1) arrDefList(r, 2) = arrDefList_temp(a, 2) arrDefList(r, 3) = arrDefList_temp(a, 3) arrDefList(r, 4) = arrDefList_temp(a, 4) arrDefList(r, 5) = arrDefList_temp(a, 5) arrDefList(r, 6) = arrDefList_temp(a, 6) arrDefList(r, 7) = arrDefList_temp(a, 7) Next a End If End If End If Next DefLinkAttribute Next DefLink ' EXTRACT PRESENTATIONLINKBASE Dim varFilePre As Variant Dim strFileTypePre As String strFileTypePre = "*_pre.xml" varFilePre = Dir(varUnzipFolder & strFileTypePre) Dim xmlDocPre As MSXML2.DOMDocument Set xmlDocPre = New MSXML2.DOMDocument xmlDocPre.async = False xmlDocPre.validateOnParse = True xmlDocPre.Load (varUnzipFolder & varFilePre) Dim NodePresLinks As MSXML2.IXMLDOMNodeList Dim PresLink As Object Dim Pres As Variant Dim NodePresLinksA As MSXML2.IXMLDOMNodeList Set NodePresLinksA = xmlDocPre.SelectNodes("//presentationLink") Dim NodePresLinksB As MSXML2.IXMLDOMNodeList Set NodePresLinksB = xmlDocPre.SelectNodes("//link:presentationLink") If NodePresLinksA.Length > 0 Then Set NodePresLinks = xmlDocPre.SelectNodes("//presentationLink") End If If NodePresLinksB.Length > 0 Then Set NodePresLinks = xmlDocPre.SelectNodes("//link:presentationLink") End If For Each PresLink In NodePresLinks For Each PresLinkAttribute In PresLink.Attributes If PresLinkAttribute.Name = "xlink:role" Then If PresLinkAttribute.Text = arrAppRoles(intRole2, 1) Then intPreLocLength = 0 intPreArcLength = 0 For Each PresLinkChild In PresLink.ChildNodes If PresLinkChild.nodeName = "loc" Or PresLinkChild.nodeName = "link:loc" Then intPreLocLength = intPreLocLength + 1 End If If PresLinkChild.nodeName = "presentationArc" Or PresLinkChild.nodeName = "link:presentationArc" Then intPreArcLength = intPreArcLength + 1 End If Next ReDim arrPreLoc(1 To intPreLocLength, 1 To 4) As Variant ReDim arrPreArc(1 To intPreArcLength, 1 To 6) As Variant l = 0 a = 0 For Each PresLinkChild In PresLink.ChildNodes If PresLinkChild.nodeName = "loc" Or PresLinkChild.nodeName = "link:loc" Then l = l + 1 arrPreLoc(l, 1) = PresLinkAttribute.Text arrPreLoc(l, 2) = PresLinkChild.nodeName For Each PresLinkChildAttribute In PresLinkChild.Attributes If PresLinkChildAttribute.Name = "xlink:href" Then arrPreLoc(l, 3) = Right(PresLinkChildAttribute.Text, Len(PresLinkChildAttribute.Text) - InStrRev(PresLinkChildAttribute.Text, "#", , vbTextCompare)) End If If PresLinkChildAttribute.Name = "xlink:label" Then arrPreLoc(l, 4) = PresLinkChildAttribute.Text End If Next End If If PresLinkChild.nodeName = "presentationArc" Or PresLinkChild.nodeName = "link:presentationArc" Then a = a + 1 arrPreArc(a, 1) = PresLinkAttribute.Text arrPreArc(a, 2) = PresLinkChild.nodeName For Each PresLinkChildAttribute In PresLinkChild.Attributes If PresLinkChildAttribute.Name = "xlink:from" Then arrPreArc(a, 3) = PresLinkChildAttribute.Text End If If PresLinkChildAttribute.Name = "xlink:to" Then arrPreArc(a, 4) = PresLinkChildAttribute.Text End If If PresLinkChildAttribute.Name = "order" Then arrPreArc(a, 5) = Val(PresLinkChildAttribute.Text) End If If PresLinkChildAttribute.Name = "preferredLabel" Then arrPreArc(a, 6) = PresLinkChildAttribute.Text End If Next End If Next Sort2dm arrPreArc, 5, xlAscending ReDim arrPreList(1 To a, 1 To 11) As Variant q = 0 For a = LBound(arrPreArc) To UBound(arrPreArc) For l = LBound(arrPreLoc) To UBound(arrPreLoc) If arrPreLoc(l, 4) = arrPreArc(a, 3) Then arrPreArc(a, 3) = arrPreLoc(l, 3) End If If arrPreLoc(l, 4) = arrPreArc(a, 4) Then arrPreArc(a, 4) = arrPreLoc(l, 3) End If Next l Next a For a = LBound(arrPreArc) To UBound(arrPreArc) Level = 0 For b = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(a, 3) = arrPreArc(b, 4) Then Level = Level + 1 End If Next b If Level = 0 Then q = q + 1 arrPreList(q, 1) = arrPreArc(a, 1) arrPreList(q, 2) = arrPreArc(a, 2) arrPreList(q, 3) = arrPreArc(a, 3) arrPreList(q, 4) = arrPreArc(a, 4) arrPreList(q, 5) = arrPreArc(a, 5) arrPreList(q, 6) = arrPreArc(a, 6) arrPreList(q, 7) = 0 For c = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(c, 3) = arrPreArc(a, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(c, 1) arrPreList(q, 2) = arrPreArc(c, 2) arrPreList(q, 3) = arrPreArc(c, 3) arrPreList(q, 4) = arrPreArc(c, 4) arrPreList(q, 5) = arrPreArc(c, 5) arrPreList(q, 6) = arrPreArc(c, 6) arrPreList(q, 7) = 1 For d = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(d, 3) = arrPreArc(c, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(d, 1) arrPreList(q, 2) = arrPreArc(d, 2) arrPreList(q, 3) = arrPreArc(d, 3) arrPreList(q, 4) = arrPreArc(d, 4) arrPreList(q, 5) = arrPreArc(d, 5) arrPreList(q, 6) = arrPreArc(d, 6) arrPreList(q, 7) = 2 For e = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(e, 3) = arrPreArc(d, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(e, 1) arrPreList(q, 2) = arrPreArc(e, 2) arrPreList(q, 3) = arrPreArc(e, 3) arrPreList(q, 4) = arrPreArc(e, 4) arrPreList(q, 5) = arrPreArc(e, 5) arrPreList(q, 6) = arrPreArc(e, 6) arrPreList(q, 7) = 3 For f = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(f, 3) = arrPreArc(e, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(f, 1) arrPreList(q, 2) = arrPreArc(f, 2) arrPreList(q, 3) = arrPreArc(f, 3) arrPreList(q, 4) = arrPreArc(f, 4) arrPreList(q, 5) = arrPreArc(f, 5) arrPreList(q, 6) = arrPreArc(f, 6) arrPreList(q, 7) = 4 For g = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(g, 3) = arrPreArc(f, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(g, 1) arrPreList(q, 2) = arrPreArc(g, 2) arrPreList(q, 3) = arrPreArc(g, 3) arrPreList(q, 4) = arrPreArc(g, 4) arrPreList(q, 5) = arrPreArc(g, 5) arrPreList(q, 6) = arrPreArc(g, 6) arrPreList(q, 7) = 5 For h = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(h, 3) = arrPreArc(g, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(h, 1) arrPreList(q, 2) = arrPreArc(h, 2) arrPreList(q, 3) = arrPreArc(h, 3) arrPreList(q, 4) = arrPreArc(h, 4) arrPreList(q, 5) = arrPreArc(h, 5) arrPreList(q, 6) = arrPreArc(h, 6) arrPreList(q, 7) = 6 For k = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(k, 3) = arrPreArc(h, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(k, 1) arrPreList(q, 2) = arrPreArc(k, 2) arrPreList(q, 3) = arrPreArc(k, 3) arrPreList(q, 4) = arrPreArc(k, 4) arrPreList(q, 5) = arrPreArc(k, 5) arrPreList(q, 6) = arrPreArc(k, 6) arrPreList(q, 7) = 7 For l = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(l, 3) = arrPreArc(k, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(l, 1) arrPreList(q, 2) = arrPreArc(l, 2) arrPreList(q, 3) = arrPreArc(l, 3) arrPreList(q, 4) = arrPreArc(l, 4) arrPreList(q, 5) = arrPreArc(l, 5) arrPreList(q, 6) = arrPreArc(l, 6) arrPreList(q, 7) = 8 For m = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(m, 3) = arrPreArc(l, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(m, 1) arrPreList(q, 2) = arrPreArc(m, 2) arrPreList(q, 3) = arrPreArc(m, 3) arrPreList(q, 4) = arrPreArc(m, 4) arrPreList(q, 5) = arrPreArc(m, 5) arrPreList(q, 6) = arrPreArc(m, 6) arrPreList(q, 7) = 9 For n = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(n, 3) = arrPreArc(m, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(n, 1) arrPreList(q, 2) = arrPreArc(n, 2) arrPreList(q, 3) = arrPreArc(n, 3) arrPreList(q, 4) = arrPreArc(n, 4) arrPreList(q, 5) = arrPreArc(n, 5) arrPreList(q, 6) = arrPreArc(n, 6) arrPreList(q, 7) = 10 For o = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(o, 3) = arrPreArc(n, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(o, 1) arrPreList(q, 2) = arrPreArc(o, 2) arrPreList(q, 3) = arrPreArc(o, 3) arrPreList(q, 4) = arrPreArc(o, 4) arrPreList(q, 5) = arrPreArc(o, 5) arrPreList(q, 6) = arrPreArc(o, 6) arrPreList(q, 7) = 11 For p = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(p, 3) = arrPreArc(o, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(p, 1) arrPreList(q, 2) = arrPreArc(p, 2) arrPreList(q, 3) = arrPreArc(p, 3) arrPreList(q, 4) = arrPreArc(p, 4) arrPreList(q, 5) = arrPreArc(p, 5) arrPreList(q, 6) = arrPreArc(p, 6) arrPreList(q, 7) = 12 For r = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(r, 3) = arrPreArc(p, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(r, 1) arrPreList(q, 2) = arrPreArc(r, 2) arrPreList(q, 3) = arrPreArc(r, 3) arrPreList(q, 4) = arrPreArc(r, 4) arrPreList(q, 5) = arrPreArc(r, 5) arrPreList(q, 6) = arrPreArc(r, 6) arrPreList(q, 7) = 13 For s = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(s, 3) = arrPreArc(r, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(s, 1) arrPreList(q, 2) = arrPreArc(s, 2) arrPreList(q, 3) = arrPreArc(s, 3) arrPreList(q, 4) = arrPreArc(s, 4) arrPreList(q, 5) = arrPreArc(s, 5) arrPreList(q, 6) = arrPreArc(s, 6) arrPreList(q, 7) = 14 For t = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(t, 3) = arrPreArc(s, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(t, 1) arrPreList(q, 2) = arrPreArc(t, 2) arrPreList(q, 3) = arrPreArc(t, 3) arrPreList(q, 4) = arrPreArc(t, 4) arrPreList(q, 5) = arrPreArc(t, 5) arrPreList(q, 6) = arrPreArc(t, 6) arrPreList(q, 7) = 15 For u = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(u, 3) = arrPreArc(t, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(u, 1) arrPreList(q, 2) = arrPreArc(u, 2) arrPreList(q, 3) = arrPreArc(u, 3) arrPreList(q, 4) = arrPreArc(u, 4) arrPreList(q, 5) = arrPreArc(u, 5) arrPreList(q, 6) = arrPreArc(u, 6) arrPreList(q, 7) = 16 For v = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(v, 3) = arrPreArc(u, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(v, 1) arrPreList(q, 2) = arrPreArc(v, 2) arrPreList(q, 3) = arrPreArc(v, 3) arrPreList(q, 4) = arrPreArc(v, 4) arrPreList(q, 5) = arrPreArc(v, 5) arrPreList(q, 6) = arrPreArc(v, 6) arrPreList(q, 7) = 17 For Z = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(Z, 3) = arrPreArc(v, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(Z, 1) arrPreList(q, 2) = arrPreArc(Z, 2) arrPreList(q, 3) = arrPreArc(Z, 3) arrPreList(q, 4) = arrPreArc(Z, 4) arrPreList(q, 5) = arrPreArc(Z, 5) arrPreList(q, 6) = arrPreArc(Z, 6) arrPreList(q, 7) = 18 For za = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(za, 3) = arrPreArc(Z, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(za, 1) arrPreList(q, 2) = arrPreArc(za, 2) arrPreList(q, 3) = arrPreArc(za, 3) arrPreList(q, 4) = arrPreArc(za, 4) arrPreList(q, 5) = arrPreArc(za, 5) arrPreList(q, 6) = arrPreArc(za, 6) arrPreList(q, 7) = 19 For zb = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(zb, 3) = arrPreArc(za, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(zb, 1) arrPreList(q, 2) = arrPreArc(zb, 2) arrPreList(q, 3) = arrPreArc(zb, 3) arrPreList(q, 4) = arrPreArc(zb, 4) arrPreList(q, 5) = arrPreArc(zb, 5) arrPreList(q, 6) = arrPreArc(zb, 6) arrPreList(q, 7) = 20 For zc = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(zc, 3) = arrPreArc(zb, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(zc, 1) arrPreList(q, 2) = arrPreArc(zc, 2) arrPreList(q, 3) = arrPreArc(zc, 3) arrPreList(q, 4) = arrPreArc(zc, 4) arrPreList(q, 5) = arrPreArc(zc, 5) arrPreList(q, 6) = arrPreArc(zc, 6) arrPreList(q, 7) = 21 For zd = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(zd, 3) = arrPreArc(zc, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(zd, 1) arrPreList(q, 2) = arrPreArc(zd, 2) arrPreList(q, 3) = arrPreArc(zd, 3) arrPreList(q, 4) = arrPreArc(zd, 4) arrPreList(q, 5) = arrPreArc(zd, 5) arrPreList(q, 6) = arrPreArc(zd, 6) arrPreList(q, 7) = 22 For ze = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(ze, 3) = arrPreArc(zd, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(ze, 1) arrPreList(q, 2) = arrPreArc(ze, 2) arrPreList(q, 3) = arrPreArc(ze, 3) arrPreList(q, 4) = arrPreArc(ze, 4) arrPreList(q, 5) = arrPreArc(ze, 5) arrPreList(q, 6) = arrPreArc(ze, 6) arrPreList(q, 7) = 23 For zf = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(zf, 3) = arrPreArc(ze, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(zf, 1) arrPreList(q, 2) = arrPreArc(zf, 2) arrPreList(q, 3) = arrPreArc(zf, 3) arrPreList(q, 4) = arrPreArc(zf, 4) arrPreList(q, 5) = arrPreArc(zf, 5) arrPreList(q, 6) = arrPreArc(zf, 6) arrPreList(q, 7) = 24 For zg = LBound(arrPreArc) To UBound(arrPreArc) If arrPreArc(zg, 3) = arrPreArc(zf, 4) Then q = q + 1 arrPreList(q, 1) = arrPreArc(zg, 1) arrPreList(q, 2) = arrPreArc(zg, 2) arrPreList(q, 3) = arrPreArc(zg, 3) arrPreList(q, 4) = arrPreArc(zg, 4) arrPreList(q, 5) = arrPreArc(zg, 5) arrPreList(q, 6) = arrPreArc(zg, 6) arrPreList(q, 7) = 25 End If Next zg End If Next zf End If Next ze End If Next zd End If Next zc End If Next zb End If Next za End If Next Z End If Next v End If Next u End If Next t End If Next s End If Next r End If Next p End If Next o End If Next n End If Next m End If Next l End If Next k End If Next h End If Next g End If Next f End If Next e End If Next d End If Next c End If Next a ' --> Combine PresentationLinkBase & DefinitionLinkbase For a = LBound(arrPreList) To UBound(arrPreList) For r = LBound(arrDefList) To UBound(arrDefList) If arrDefList(r, 1) = arrPreList(a, 1) And arrPreList(a, 4) = arrDefList(r, 4) And arrDefList(r, 6) <> "http://xbrl.org/int/dim/arcrole/dimension-default" Then arrPreList(a, 9) = arrDefList(r, 3) arrPreList(a, 10) = arrDefList(r, 4) arrPreList(a, 11) = arrDefList(r, 6) End If Next r Next a '--> Combine PresentationLinkBase & DefinitionLinkbase & Line Items intMaxStatementLength = 0 For apl = LBound(arrPreList) To UBound(arrPreList) For x = LBound(arrGAAP) To UBound(arrGAAP) If arrGAAP(x, 1) <> "" And arrGAAP(x, 1) <> "context" And arrGAAP(x, 1) <> "unit" And arrGAAP(x, 1) <> "xbrli:context" And arrGAAP(x, 1) <> "xbrli:unit" Then If arrGAAP(x, 1) = Replace(arrPreList(apl, 4), "_", ":") Then intMaxStatementLength = intMaxStatementLength + 1 End If End If Next x Next apl ReDim arrStatement(1 To intMaxStatementLength, 1 To 27) As Variant zh = 0 StatementLength = 0 NosAxis = 0 ReDim AxisDomain1(1 To UBound(arrContextList), 1 To 2) As Variant ReDim AxisDomain2(1 To UBound(arrContextList), 1 To 2) As Variant ReDim AxisDomain3(1 To UBound(arrContextList), 1 To 2) As Variant Domain1 = 0 Domain2 = 0 Domain3 = 0 For apl = LBound(arrPreList) To UBound(arrPreList) If arrPreList(apl, 11) = "http://xbrl.org/int/dim/arcrole/dimension-domain" And NosAxis = 0 Then NosAxis = NosAxis + 1 For ZJ = LBound(arrPreList) To UBound(arrPreList) If arrPreList(apl, 10) = arrPreList(ZJ, 9) Then Domain1 = Domain1 + 1 AxisDomain1(Domain1, 1) = arrPreList(apl, 9) AxisDomain1(Domain1, 2) = arrPreList(ZJ, 4) End If Next ZJ End If If arrPreList(apl, 11) = "http://xbrl.org/int/dim/arcrole/dimension-domain" And arrPreList(apl, 3) <> "dei_LegalEntityAxis" And arrPreList(apl, 9) <> AxisDomain1(1, 1) And arrPreList(apl, 9) <> AxisDomain3(1, 1) And NosAxis = 1 Then NosAxis = NosAxis + 1 For ZJ = LBound(arrPreList) To UBound(arrPreList) If arrPreList(apl, 10) = arrPreList(ZJ, 9) Then Domain2 = Domain2 + 1 AxisDomain2(Domain2, 1) = arrPreList(apl, 9) AxisDomain2(Domain2, 2) = arrPreList(ZJ, 4) End If Next ZJ End If If arrPreList(apl, 11) = "http://xbrl.org/int/dim/arcrole/dimension-domain" And arrPreList(apl, 3) <> "dei_LegalEntityAxis" And arrPreList(apl, 9) <> AxisDomain1(1, 1) And arrPreList(apl, 9) <> AxisDomain2(1, 1) And NosAxis = 2 Then NosAxis = NosAxis + 1 For ZJ = LBound(arrPreList) To UBound(arrPreList) If arrPreList(apl, 10) = arrPreList(ZJ, 9) Then Domain3 = Domain3 + 1 AxisDomain3(Domain3, 1) = arrPreList(apl, 9) AxisDomain3(Domain3, 2) = arrPreList(ZJ, 4) End If Next ZJ End If For x = LBound(arrGAAP) To UBound(arrGAAP) If arrGAAP(x, 1) <> "" And arrGAAP(x, 1) <> "context" And arrGAAP(x, 1) <> "unit" And arrGAAP(x, 1) <> "xbrli:context" And arrGAAP(x, 1) <> "xbrli:unit" Then If arrGAAP(x, 1) = Replace(arrPreList(apl, 4), "_", ":") Then zh = zh + 1 StatementLength = StatementLength + 1 arrStatement(zh, 1) = arrGAAP(x, 1) arrStatement(zh, 2) = arrGAAP(x, 2) arrStatement(zh, 3) = arrGAAP(x, 3) arrStatement(zh, 4) = arrGAAP(x, 4) arrStatement(zh, 5) = arrGAAP(x, 5) arrStatement(zh, 6) = arrGAAP(x, 6) arrStatement(zh, 7) = arrGAAP(x, 7) arrStatement(zh, 8) = arrGAAP(x, 8) arrStatement(zh, 9) = arrGAAP(x, 9) arrStatement(zh, 10) = arrGAAP(x, 10) arrStatement(zh, 11) = arrGAAP(x, 11) arrStatement(zh, 12) = arrGAAP(x, 12) arrStatement(zh, 13) = arrGAAP(x, 13) arrStatement(zh, 14) = arrGAAP(x, 14) arrStatement(zh, 15) = arrGAAP(x, 15) arrStatement(zh, 16) = arrGAAP(x, 16) arrStatement(zh, 17) = arrGAAP(x, 17) arrStatement(zh, 18) = arrGAAP(x, 18) arrStatement(zh, 19) = arrGAAP(x, 19) arrStatement(zh, 20) = arrGAAP(x, 20) arrStatement(zh, 21) = arrGAAP(x, 21) arrStatement(zh, 22) = arrGAAP(x, 19) & "_" & arrGAAP(x, 20) & "_" & arrGAAP(x, 21) arrStatement(zh, 23) = arrGAAP(x, 22) arrStatement(zh, 24) = arrGAAP(x, 23) arrStatement(zh, 25) = arrGAAP(x, 24) arrStatement(zh, 26) = arrGAAP(x, 25) arrStatement(zh, 27) = arrGAAP(x, 26) End If End If Next x Next apl '-->Get Unique Timeline ReDim arrContextListUnique(1 To UBound(arrContextList), 1 To 4) As Variant Dim toAdd As Boolean, ZK As Integer, ZL As Integer arrContextListUnique(1, 1) = arrStatement(1, 19) arrContextListUnique(1, 2) = arrStatement(1, 20) arrContextListUnique(1, 3) = arrStatement(1, 21) arrContextListUnique(1, 4) = arrStatement(1, 22) uniqueNumbers = 1 toAdd = True For ZK = LBound(arrStatement) To UBound(arrStatement) For ZL = 1 To uniqueNumbers If arrStatement(ZK, 22) = arrContextListUnique(ZL, 4) Then toAdd = False End If Next ZL If toAdd = True Then arrContextListUnique(uniqueNumbers + 1, 1) = arrStatement(ZK, 19) arrContextListUnique(uniqueNumbers + 1, 2) = arrStatement(ZK, 20) arrContextListUnique(uniqueNumbers + 1, 3) = arrStatement(ZK, 21) arrContextListUnique(uniqueNumbers + 1, 4) = arrStatement(ZK, 22) uniqueNumbers = uniqueNumbers + 1 End If toAdd = True Next ZK '<--Get Unique Timeline '<-- Sort arrContextListUnique For suc = LBound(arrContextListUnique) To UBound(arrContextListUnique) If arrContextListUnique(suc, 1) <> "" Then arrContextListUnique(suc, 3) = arrContextListUnique(suc, 1) End If Next suc Sort2dm arrContextListUnique, 3, xlDescending If Domain1 = 0 Then Domain1 = 1 End If If StatementLength < UBound(arrPreList) Then ReDim arrStatement2(1 To (UBound(arrPreList) * (1 + Domain1 + Domain2 + Domain3 + Domain1 * Domain2 + Domain1 * Domain2 * Domain3 + Domain1 * Domain3 + Domain2 * Domain3)) + 4, 1 To uniqueNumbers + 15) As Variant Else ReDim arrStatement2(1 To (StatementLength * (1 + Domain1 + Domain2 + Domain3 + Domain1 * Domain2 + Domain1 * Domain2 * Domain3 + Domain1 * Domain3 + Domain2 * Domain3)) + 4, 1 To uniqueNumbers + 15) As Variant End If For y = 1 To uniqueNumbers arrStatement2(1, y + 15) = arrContextListUnique(y, 1) arrStatement2(2, y + 15) = arrContextListUnique(y, 2) arrStatement2(3, y + 15) = arrContextListUnique(y, 3) arrStatement2(4, y + 15) = arrContextListUnique(y, 4) Next y q = 0 For y = LBound(arrPreList) To UBound(arrPreList) q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) '1 For x = LBound(AxisDomain1) To UBound(AxisDomain1) If AxisDomain1(x, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain1(x, 1) arrStatement2(q + 4, 8) = AxisDomain1(x, 2) End If Next x '2 For x = LBound(AxisDomain2) To UBound(AxisDomain2) If AxisDomain2(x, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain2(x, 1) arrStatement2(q + 4, 8) = AxisDomain2(x, 2) End If Next x '3 For x = LBound(AxisDomain3) To UBound(AxisDomain3) If AxisDomain3(x, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain3(x, 1) arrStatement2(q + 4, 8) = AxisDomain3(x, 2) End If Next x '1/2/3 For x = LBound(AxisDomain1) To UBound(AxisDomain1) If AxisDomain1(x, 1) <> "" Then For Z = LBound(AxisDomain2) To UBound(AxisDomain2) If AxisDomain2(Z, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain1(x, 1) & "[" & AxisDomain2(Z, 1) & "]" arrStatement2(q + 4, 8) = AxisDomain1(x, 2) & "[" & AxisDomain2(Z, 2) & "]" For a = LBound(AxisDomain3) To UBound(AxisDomain3) If AxisDomain3(a, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain1(x, 1) & "[" & AxisDomain2(Z, 1) & "][" & AxisDomain3(a, 1) & "]" arrStatement2(q + 4, 8) = AxisDomain1(x, 2) & "[" & AxisDomain2(Z, 2) & "][" & AxisDomain3(a, 2) & "]" End If Next a End If Next Z End If Next x '1/3 For x = LBound(AxisDomain1) To UBound(AxisDomain1) If AxisDomain1(x, 1) <> "" Then For a = LBound(AxisDomain3) To UBound(AxisDomain3) If AxisDomain3(a, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain1(x, 1) & "[" & AxisDomain3(a, 1) & "]" arrStatement2(q + 4, 8) = AxisDomain1(x, 2) & "[" & AxisDomain3(a, 2) & "]" End If Next a End If Next x '2/3 For x = LBound(AxisDomain2) To UBound(AxisDomain2) If AxisDomain2(x, 1) <> "" Then For a = LBound(AxisDomain3) To UBound(AxisDomain3) If AxisDomain3(a, 1) <> "" Then q = q + 1 arrStatement2(q + 4, 1) = arrPreList(y, 1) arrStatement2(q + 4, 2) = arrPreList(y, 4) arrStatement2(q + 4, 6) = arrPreList(y, 6) arrStatement2(q + 4, 4) = arrPreList(y, 7) arrStatement2(q + 4, 7) = AxisDomain2(x, 1) & "[" & AxisDomain3(a, 1) & "]" arrStatement2(q + 4, 8) = AxisDomain2(x, 2) & "[" & AxisDomain3(a, 2) & "]" End If Next a End If Next x Next y For x = LBound(arrStatement2) To UBound(arrStatement2) For y = LBound(arrAppRoles) To UBound(arrAppRoles) If arrStatement2(x, 1) = arrAppRoles(y, 1) Then arrStatement2(x, 5) = arrAppRoles(y, 2) End If Next y Next x For x = LBound(arrStatement2) To UBound(arrStatement2) For Z = LBound(arrStatement) To UBound(arrStatement) ' No Dimension If arrStatement(Z, 9) = "" And arrStatement2(x, 7) = "" Then If arrStatement(Z, 1) = Replace(arrStatement2(x, 2), "_", ":") Then For y = 15 To uniqueNumbers + 15 If arrStatement(Z, 19) <> "" Then If arrStatement2(x, 6) = "http://www.xbrl.org/2003/role/periodStartLabel" Then If CDate(arrStatement(Z, 19)) + 1 = CDate(arrStatement2(2, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If If arrStatement2(x, 6) = "http://www.xbrl.org/2003/role/periodEndLabel" Then If CDate(arrStatement(Z, 19)) = CDate(arrStatement2(3, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If If arrStatement2(x, 6) <> "http://www.xbrl.org/2003/role/periodStartLabel" And arrStatement2(x, 6) <> "http://www.xbrl.org/2003/role/periodEndLabel" Then If CDate(arrStatement(Z, 19)) = CDate(arrStatement2(1, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If End If If arrStatement(Z, 20) <> "" And arrStatement(Z, 21) <> "" Then If CDate(arrStatement(Z, 20)) = CDate(arrStatement2(2, y)) And CDate(arrStatement(Z, 21)) = CDate(arrStatement2(3, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If Next y End If End If ' Dimension If arrStatement(Z, 9) <> "" And arrStatement2(x, 7) <> "" Then If arrStatement(Z, 1) = Replace(arrStatement2(x, 2), "_", ":") Then Dim StatementAxisCum As String Dim StatementDomainCum As String If arrStatement(Z, 9) <> "" And arrStatement(Z, 11) = "" And arrStatement(Z, 13) = "" And arrStatement(Z, 15) = "" And arrStatement(Z, 17) = "" Then StatementAxisCum = arrStatement(Z, 9) StatementDomainCum = arrStatement(Z, 10) End If If arrStatement(Z, 9) <> "" And arrStatement(Z, 11) <> "" And arrStatement(Z, 13) = "" And arrStatement(Z, 15) = "" And arrStatement(Z, 17) = "" Then StatementAxisCum = arrStatement(Z, 9) & "[" & arrStatement(Z, 11) & "]" StatementDomainCum = arrStatement(Z, 10) & "[" & arrStatement(Z, 12) & "]" End If If arrStatement(Z, 9) <> "" And arrStatement(Z, 11) <> "" And arrStatement(Z, 13) <> "" And arrStatement(Z, 15) = "" And arrStatement(Z, 17) = "" Then StatementAxisCum = arrStatement(Z, 9) & "[" & arrStatement(Z, 11) & "][" & arrStatement(Z, 13) & "]" StatementDomainCum = arrStatement(Z, 10) & "[" & arrStatement(Z, 12) & "][" & arrStatement(Z, 14) & "]" End If If arrStatement(Z, 9) <> "" And arrStatement(Z, 11) <> "" And arrStatement(Z, 13) <> "" And arrStatement(Z, 15) <> "" And arrStatement(Z, 17) = "" Then StatementAxisCum = arrStatement(Z, 9) & "[" & arrStatement(Z, 11) & "][" & arrStatement(Z, 13) & "][" & arrStatement(Z, 15) & "]" StatementDomainCum = arrStatement(Z, 10) & "[" & arrStatement(Z, 12) & "][" & arrStatement(Z, 14) & "][" & arrStatement(Z, 16) & "]" End If If arrStatement(Z, 9) <> "" And arrStatement(Z, 11) <> "" And arrStatement(Z, 13) <> "" And arrStatement(Z, 15) <> "" And arrStatement(Z, 17) <> "" Then StatementAxisCum = arrStatement(Z, 9) & "[" & arrStatement(Z, 11) & "][" & arrStatement(Z, 13) & "][" & arrStatement(Z, 15) & "][" & arrStatement(Z, 17) & "]" StatementDomainCum = arrStatement(Z, 10) & "[" & arrStatement(Z, 12) & "][" & arrStatement(Z, 14) & "][" & arrStatement(Z, 16) & "][" & arrStatement(Z, 18) & "]" End If If StatementAxisCum = Replace(arrStatement2(x, 7), "_", ":") And StatementDomainCum = Replace(arrStatement2(x, 8), "_", ":") Then For y = 15 To uniqueNumbers + 15 If arrStatement(Z, 19) <> "" Then If arrStatement2(x, 6) = "http://www.xbrl.org/2003/role/periodStartLabel" Then If CDate(arrStatement(Z, 19)) + 1 = CDate(arrStatement2(2, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If If arrStatement2(x, 6) = "http://www.xbrl.org/2003/role/periodEndLabel" Then If CDate(arrStatement(Z, 19)) = CDate(arrStatement2(3, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If If arrStatement2(x, 6) <> "http://www.xbrl.org/2003/role/periodStartLabel" And arrStatement2(x, 6) <> "http://www.xbrl.org/2003/role/periodEndLabel" Then If CDate(arrStatement(Z, 19)) = CDate(arrStatement2(1, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If End If If arrStatement(Z, 20) <> "" And arrStatement(Z, 21) <> "" Then If CDate(arrStatement(Z, 20)) = CDate(arrStatement2(2, y)) And CDate(arrStatement(Z, 21)) = CDate(arrStatement2(3, y)) Then arrStatement2(x, y) = arrStatement(Z, 2) & " [decimals:" & arrStatement(Z, 5) & "]" & " [unit:" & arrStatement(Z, 25) & "] [numerator:" & arrStatement(Z, 26) & "] [denominator:" & arrStatement(Z, 27) & "]" End If End If Next y arrStatement2(x, 9) = arrStatement2(x, 2) & " [" & arrStatement2(x, 8) & "] " End If End If End If Next Z Next x For x = LBound(arrStatement2) To UBound(arrStatement2) 'Get Non or Single-Domain Label For y = LBound(arrLabelList) To UBound(arrLabelList) If arrStatement2(x, 2) = arrLabelList(y, 9) Then If arrStatement2(x, 6) = "" And arrLabelList(y, 4) = "http://www.xbrl.org/2003/role/label" Then arrStatement2(x, 3) = arrLabelList(y, 5) End If If arrStatement2(x, 6) <> "" And arrStatement2(x, 6) = arrLabelList(y, 4) Then arrStatement2(x, 3) = arrLabelList(y, 5) End If End If If arrStatement2(x, 8) = arrLabelList(y, 9) Then Dim domainlabel3 As String For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, 2) = arrStatement2(x, 8) Then domainlabel3 = arrStatement2(x1, 6) End If Next x1 If domainlabel3 = "" And arrLabelList(y, 4) = "http://www.xbrl.org/2003/role/label" Then arrStatement2(x, 10) = arrLabelList(y, 5) End If If domainlabel3 <> "" And domainlabel3 = arrLabelList(y, 4) Then arrStatement2(x, 10) = arrLabelList(y, 5) End If End If Next y 'Get Multi-Domain Label If InStr(arrStatement2(x, 8), "[") > 0 Then Dim arrMultiDomain As Variant ReDim arrMultiDomain(1 To 5, 1 To 1) As Variant Dim DomainSplit() As String intDomainSplitLength = 0 DomainSplit() = Split(arrStatement2(x, 8), "[") For ds = LBound(DomainSplit) To UBound(DomainSplit) intDomainSplitLength = intDomainSplitLength + 1 For y = LBound(arrLabelList) To UBound(arrLabelList) If InStr(DomainSplit(ds), "]") = 0 Then If DomainSplit(ds) = arrLabelList(y, 9) Then Dim domainlabel2 As String For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, 2) = DomainSplit(ds) Then domainlabel2 = arrStatement2(x1, 6) Exit For End If Next x1 If domainlabel2 <> "" And domainlabel2 = arrLabelList(y, 4) Then arrMultiDomain(intDomainSplitLength, 1) = arrLabelList(y, 5) End If End If Else If Replace(DomainSplit(ds), "]", "") = arrLabelList(y, 9) Then Dim domainlabel As String For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, 2) = Replace(DomainSplit(ds), "]", "") Then domainlabel = arrStatement2(x1, 6) Exit For End If Next x1 If domainlabel <> "" And domainlabel = arrLabelList(y, 4) Then arrMultiDomain(intDomainSplitLength, 1) = arrLabelList(y, 5) End If End If End If Next y Next ds If intDomainSplitLength = 2 Then arrStatement2(x, 11) = arrStatement2(x, 3) & " | " & arrMultiDomain(1, 1) & " | " & arrMultiDomain(2, 1) End If If intDomainSplitLength = 3 Then arrStatement2(x, 11) = arrStatement2(x, 3) & " | " & arrMultiDomain(1, 1) & " | " & arrMultiDomain(2, 1) & " | " & arrMultiDomain(3, 1) End If If intDomainSplitLength = 4 Then arrStatement2(x, 11) = arrStatement2(x, 3) & " | " & arrMultiDomain(1, 1) & " | " & arrMultiDomain(2, 1) & " | " & arrMultiDomain(3, 1) & "| " & arrMultiDomain(4, 1) End If If intDomainSplitLength = 5 Then arrStatement2(x, 11) = arrStatement2(x, 3) & " | " & arrMultiDomain(1, 1) & " | " & arrMultiDomain(2, 1) & " | " & arrMultiDomain(3, 1) & "| " & arrMultiDomain(4, 1) & "| " & arrMultiDomain(5, 1) End If End If If arrStatement2(x, 10) <> "" And arrStatement2(x, 11) = "" Then arrStatement2(x, 11) = arrStatement2(x, 3) & " | " & arrStatement2(x, 10) End If If arrStatement2(x, 11) <> "" Then arrStatement2(x, 3) = arrStatement2(x, 11) arrStatement2(x, 2) = arrStatement2(x, 9) End If Next x Call B_PrintStatements.PrintStatements End If End If Next PresLinkAttribute Next PresLink End If End If End If Next intRole2 Call C_RatioCalculation.RatioCalculation End If End If varFileInstance = Dir Loop End If Next i On Error Resume Next End If If intDocTypeTest = 0 Then If Error = "True" Then Else MsgBox "Hinweis: es wurde kein auswertbares 10-K XBRL Dokument selektiert. Bitte passen Sie Ihre Auswahl an." End If End If End Sub ________________________________________________________________________ Function GetFolder(strPath As String) As String Dim fldr As FileDialog Dim sItem As String Set fldr = Application.FileDialog(msoFileDialogFolderPicker) With fldr .Title = "Select a Folder" .AllowMultiSelect = False .InitialFileName = strPath If .Show <> -1 Then GoTo NextCode sItem = .SelectedItems(1) End With NextCode: GetFolder = sItem Set fldr = Nothing End Function ________________________________________________________________________ Function Sort2dm(InputArray As Variant, Optional SortColumn As Integer = 1, Optional SortOrder As SortType = xlAscending) As Variant Dim varFirst As Variant Dim vartLast As Variant Dim varFirstCol As Variant Dim varLastCol As Variant Dim varTemp As Variant Dim varLoop As Variant Dim i As Variant Dim k As Variant Dim blnFlag As Boolean Dim blnSort As Boolean If Not IsArray(InputArray) Then blnFlag = True GoTo ExitEarly: End If varFirst = LBound(InputArray, 1) vartLast = UBound(InputArray, 1) varFirstCol = LBound(InputArray, 2) varLastCol = UBound(InputArray, 2) For i = varFirst To (vartLast - 1) For varLoop = i + 1 To vartLast If SortOrder = xlAscending Then If InputArray(i, SortColumn) > InputArray(varLoop, SortColumn) Then blnSort = True Else If InputArray(i, SortColumn) < InputArray(varLoop, SortColumn) Then blnSort = True End If If blnSort Then For k = varFirstCol To varLastCol varTemp = InputArray(varLoop, k) InputArray(varLoop, k) = InputArray(i, k) InputArray(i, k) = varTemp Next k End If blnSort = False Next varLoop Next i Sort2dm = InputArray ExitEarly: If blnFlag Then Sort2dm = Null End Function
Sub PrintStatements() strStatement2 = StrConv(arrStatement2(5, 5), vbLowerCase) If strStatement2 Like "*statement*" And Not strStatement2 Like "*parenthetical*" And Not strStatement2 Like "*disclosure*" And Not strStatement2 Like "*(detail)*" Then ' Print Balance Sheet If strStatement2 Like "*balance*sheet*" Or strStatement2 Like "*financial*position*" Or strStatement2 Like "*condition*" Then If Tabelle2.Cells(2, 2) = "" Then Tabelle2.Cells(4, 2) = "Line Item" Tabelle2.Cells(4, 3) = "Label" Tabelle2.Cells(4, 4) = "Level" Z = 0 For x = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x, 8) = "" Or arrStatement2(x, 9) <> "" Then Z = Z + 1 u = 15 For y = 1 To uniqueNumbers + 15 If x <> 4 And y <= 15 Then Tabelle2.Cells(2, 2) = arrStatement2(5, 5) Tabelle2.Cells(Z, y) = arrStatement2(x, y) End If '--> Add Instant Timeline If CDate(arrStatement2(1, y) <> "") Then If (CDate(Tabelle1.Cells(21, 5)) = CDate(arrStatement2(1, y)) Or (CDate(Tabelle1.Cells(21, 5)) - CDate(arrStatement2(1, y)) > 360) And CDate(Tabelle1.Cells(21, 5)) >= CDate(arrStatement2(1, y))) Then If y > 15 And x <> 4 Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Tabelle2.Cells(Z, u) = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Tabelle2.Cells(Z, u) = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Tabelle2.Cells(Z, u) = (arrStatement2(x, y)) End If End If End If End If End If Next y '<-- Add Instant Timeline '--> Add Duration Timeline Dim LastRow_BS1 As Long With ActiveSheet LastRow_BS1 = Tabelle2.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_BS1 As Object Dim List_BS1 As Range Set List_BS1 = Tabelle2.Range("B5:B" & LastRow_BS1) For Each Row_BS1 In List_BS1 If Row_BS1 = arrStatement2(x, 2) And Row_BS1.Next = arrStatement2(x, 3) Then For y = 1 To uniqueNumbers + 15 If (CDate(Tabelle2.Cells(3, 16)) = CDate(arrStatement2(3, y)) And CDate(arrStatement2(1, y) = "")) Then If CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) > 349 And CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) < 375 And CDate(Tabelle1.Cells(21, 5)) >= CDate(arrStatement2(3, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If (CDate(Tabelle2.Cells(3, 17)) = CDate(arrStatement2(3, y)) And CDate(arrStatement2(1, y) = "")) Then If CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) > 349 And CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) < 375 And CDate(Tabelle1.Cells(21, 5)) >= CDate(arrStatement2(3, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_BS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If Next y End If Next Row_BS1 '<-- Add Duration Timeline End If Next x End If End If ' Print Income Statement If (strStatement2 Like "*income*" Or strStatement2 Like "*operation*" Or strStatement2 Like "*earnings*") And Not strStatement2 Like "*comprehensive*" And Not strStatement2 Like "*nature*" Then If Tabelle3.Cells(2, 2) = "" Then Tabelle3.Cells(4, 2) = "Line Item" Tabelle3.Cells(4, 3) = "Label" Tabelle3.Cells(4, 4) = "Level" Z = 0 For x = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x, 8) = "" Or arrStatement2(x, 9) <> "" Then Z = Z + 1 u = 15 For y = 1 To uniqueNumbers + 15 If x <> 4 And y <= 15 Then Tabelle3.Cells(2, 2) = arrStatement2(5, 5) Tabelle3.Cells(Z, y) = arrStatement2(x, y) End If '--> Add Duration Timeline If CDate(arrStatement2(1, y) = "") Then If CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) > 349 And CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) < 375 And CDate(Tabelle1.Cells(21, 5)) >= CDate(arrStatement2(3, y)) And y > 14 And x <> 4 And u < 18 Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 1 And x1 <> 2 And x1 <> 3 And x1 <> 4 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Tabelle3.Cells(Z, u) = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Tabelle3.Cells(Z, u) = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Tabelle3.Cells(Z, u) = (arrStatement2(x, y)) End If End If End If End If Next y '<-- Add Duration Timeline '--> Add Instant Timeline Dim LastRow_IS1 As Long With ActiveSheet LastRow_IS1 = Tabelle3.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_IS1 As Object Dim List_IS1 As Range Set List_IS1 = Tabelle3.Range("B5:B" & LastRow_IS1) For Each Row_IS1 In List_IS1 If Row_IS1 = arrStatement2(x, 2) And Row_IS1.Next = arrStatement2(x, 3) Then For y = 1 To uniqueNumbers + 15 If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle3.Cells(3, 16)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle3.Cells(3, 17)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle3.Cells(3, 18)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_IS1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If Next y End If Next Row_IS1 '<-- Add Instant Timeline End If Next x End If End If ' Print Comprehensive Income Statement If strStatement2 Like "*comprehensive*" And Not strStatement2 Like "*equity*" Then If Tabelle4.Cells(2, 2) = "" Then Tabelle4.Cells(4, 2) = "Line Item" Tabelle4.Cells(4, 3) = "Label" Tabelle4.Cells(4, 4) = "Level" Z = 0 For x = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x, 8) = "" Or arrStatement2(x, 9) <> "" Then Z = Z + 1 u = 15 For y = 1 To uniqueNumbers + 15 If x <> 4 And y <= 15 Then Tabelle4.Cells(2, 2) = arrStatement2(5, 5) Tabelle4.Cells(Z, y) = arrStatement2(x, y) End If '--> Add Duration Timeline If CDate(arrStatement2(1, y) = "") Then If CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) > 349 And CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) < 375 And CDate(Tabelle1.Cells(21, 5)) >= CDate(arrStatement2(3, y)) And y > 14 And x <> 4 And u < 18 Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 1 And x1 <> 2 And x1 <> 3 And x1 <> 4 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Tabelle4.Cells(Z, u) = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Tabelle4.Cells(Z, u) = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Tabelle4.Cells(Z, u) = (arrStatement2(x, y)) End If End If End If End If Next y '<-- Add Duration Timeline '--> Add Instant Timeline Dim LastRow_CI1 As Long With ActiveSheet LastRow_CI1 = Tabelle4.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_CI1 As Object Dim List_CI1 As Range Set List_CI1 = Tabelle4.Range("B5:B" & LastRow_CI1) For Each Row_CI1 In List_CI1 If Row_CI1 = arrStatement2(x, 2) And Row_CI1.Next = arrStatement2(x, 3) Then For y = 1 To uniqueNumbers + 15 If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle4.Cells(3, 16)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle4.Cells(3, 17)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle4.Cells(3, 18)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_CI1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If Next y End If Next Row_CI1 '<-- Add Instant Timeline End If Next x End If End If ' Print Cashflow Statement If strStatement2 Like "*cash*flow*" Then If Tabelle5.Cells(2, 2) = "" Then Tabelle5.Cells(4, 2) = "Line Item" Tabelle5.Cells(4, 3) = "Label" Tabelle5.Cells(4, 4) = "Level" Z = 0 For x = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x, 8) = "" Or arrStatement2(x, 9) <> "" Then Z = Z + 1 u = 15 For y = 1 To uniqueNumbers + 15 If x <> 4 And y <= 15 Then Tabelle5.Cells(2, 2) = arrStatement2(5, 5) Tabelle5.Cells(Z, y) = arrStatement2(x, y) End If '--> Add Duration Timeline If CDate(arrStatement2(1, y) = "") Then If CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) > 349 And CDate(arrStatement2(3, y)) - CDate(arrStatement2(2, y)) < 375 And CDate(Tabelle1.Cells(21, 5)) >= CDate(arrStatement2(3, y)) And y > 14 And x <> 4 And u < 18 Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 1 And x1 <> 2 And x1 <> 3 And x1 <> 4 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Tabelle5.Cells(Z, u) = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Tabelle5.Cells(Z, u) = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Tabelle5.Cells(Z, u) = (arrStatement2(x, y)) End If End If End If End If Next y '<-- Add Duration Timeline '--> Add Instant Timeline Dim LastRow_CF1 As Long With ActiveSheet LastRow_CF1 = Tabelle5.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_CF1 As Object Dim List_CF1 As Range Set List_CF1 = Tabelle5.Range("B5:B" & LastRow_CF1) For Each Row_CF1 In List_CF1 If Row_CF1 = arrStatement2(x, 2) And Row_CF1.Next = arrStatement2(x, 3) Then For y = 1 To uniqueNumbers + 15 If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle5.Cells(3, 16)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle5.Cells(3, 17)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If If CDate(arrStatement2(1, y) <> "") And CDate(arrStatement2(2, y) = "") Then If CDate(Tabelle5.Cells(3, 18)) = CDate(arrStatement2(1, y)) Then ' Test for empty columns items = 0 For x1 = LBound(arrStatement2) To UBound(arrStatement2) If arrStatement2(x1, y) <> "" And x1 <> 4 And x1 <> 1 Then items = items + 1 End If Next x1 If items > 0 Then u = u + 1 If Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = "" Then If arrStatement2(x, 6) Like "*negated*" Or arrStatement2(x, 6) Like "*Negated*" Then If arrStatement2(x, y) <> "" Then If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) < 0 Then Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace(Abs(Val(Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [")) - 1)), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If If Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1) >= 0 Then Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Replace((Val((Left(arrStatement2(x, y), InStr(arrStatement2(x, y), " [") - 1))) * -1), ",", ".") & " [" & Right(arrStatement2(x, y), Len(arrStatement2(x, y)) - InStr(arrStatement2(x, y), " [") - 1) End If End If Else Row_CF1.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = (arrStatement2(x, y)) End If End If End If End If End If Next y End If Next Row_CF1 '<-- Add Instant Timeline End If Next x End If End If End If End Sub
Public Sub RatioCalculation() Tabelle1.Cells(26, 4).ClearContents Tabelle1.Cells(26, 5).ClearContents Tabelle1.Cells(28, 4).ClearContents Tabelle1.Cells(28, 5).ClearContents Tabelle1.Cells(30, 4).ClearContents Tabelle1.Cells(30, 5).ClearContents Tabelle1.Cells(32, 4).ClearContents Tabelle1.Cells(32, 5).ClearContents Tabelle1.Cells(34, 4).ClearContents Tabelle1.Cells(34, 5).ClearContents Tabelle1.Cells(36, 4).ClearContents Tabelle1.Cells(36, 5).ClearContents Tabelle1.Cells(40, 4).ClearContents Tabelle1.Cells(40, 5).ClearContents Tabelle1.Cells(42, 4).ClearContents Tabelle1.Cells(42, 5).ClearContents Tabelle1.Cells(44, 4).ClearContents Tabelle1.Cells(44, 5).ClearContents Tabelle1.Cells(46, 4).ClearContents Tabelle1.Cells(46, 5).ClearContents Tabelle1.Cells(50, 4).ClearContents Tabelle1.Cells(50, 5).ClearContents Tabelle1.Cells(52, 4).ClearContents Tabelle1.Cells(52, 5).ClearContents Tabelle1.Cells(54, 4).ClearContents Tabelle1.Cells(54, 5).ClearContents Tabelle1.Cells(58, 4).ClearContents Tabelle1.Cells(58, 5).ClearContents Tabelle1.Cells(60, 4).ClearContents Tabelle1.Cells(60, 5).ClearContents Tabelle1.Cells(62, 4).ClearContents Tabelle1.Cells(62, 5).ClearContents Tabelle1.Cells(64, 4).ClearContents Tabelle1.Cells(64, 5).ClearContents Tabelle1.Cells(66, 4).ClearContents Tabelle1.Cells(66, 5).ClearContents ReDim CashAndCashEquivalents(1 To 1, 1 To 2) As Variant ReDim PropertyPlantEquipment(1 To 1, 1 To 2) As Variant ReDim Receivables(1 To 1, 1 To 2) As Variant ReDim Inventory(1 To 1, 1 To 2) As Variant ReDim AssetsCurrent(1 To 1, 1 To 2) As Variant ReDim Assets(1 To 1, 1 To 2) As Variant ReDim LiabilitiesCurrent(1 To 1, 1 To 2) As Variant ReDim Liabilities(1 To 1, 1 To 2) As Variant ReDim Equity(1 To 1, 1 To 2) As Variant ReDim Revenues(1 To 1, 1 To 2) As Variant ReDim CostOfGoodsAndServicesSold(1 To 1, 1 To 2) As Variant ReDim CostofGoodsSold(1 To 1, 1 To 2) As Variant ReDim CostOfServices(1 To 1, 1 To 2) As Variant ReDim GrossProfit(1 To 1, 1 To 2) As Variant ReDim OperatingIncome(1 To 1, 1 To 2) As Variant ReDim NetIncome(1 To 1, 1 To 2) As Variant ReDim OCF(1 To 1, 1 To 2) As Variant Dim LastRow_BS As Long With ActiveSheet LastRow_BS = Tabelle2.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_BS As Object Dim List_BS As Range Set List_BS = Tabelle2.Range("B5:B" & LastRow_BS) Dim LastRow_IS As Long With ActiveSheet LastRow_IS = Tabelle3.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_IS As Object Dim List_IS As Range Set List_IS = Tabelle3.Range("B5:B" & LastRow_IS) Dim LastRow_CI As Long With ActiveSheet LastRow_CI = Tabelle4.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_CI As Object Dim List_CI As Range Set List_CI = Tabelle4.Range("B5:B" & LastRow_CI) Dim LastRow_CF As Long With ActiveSheet LastRow_CF = Tabelle5.Cells(Rows.Count, 2).End(xlUp).Row End With Dim Row_CF As Object Dim List_CF As Range Set List_CF = Tabelle5.Range("B5:B" & LastRow_CF) Dim intCurrenyBS As Integer intCurrenyBS = 0 Dim intCurrenyIS As Integer intCurrenyIS = 0 Dim intCurrenyCI As Integer intCurrenyCI = 0 Dim intCurrenyCF As Integer intCurrenyCF = 0 ' Statement of Financial Position If Tabelle2.Cells(2, 2).Value <> "" Then If Tabelle1.Cells(21, 5) = Tabelle2.Cells(1, 16) Then For Each Row_BS In List_BS If InStr(Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, "[unit:iso4217:USD]") > 0 Then intCurrenyBS = intCurrenyBS + 1 End If If Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Left(Row_BS, 7) = "us-gaap" Then If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "CashAndCashEquivalentsAtCarryingValue" Then CashAndCashEquivalents(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "PropertyPlantAndEquipmentNet" Then PropertyPlantEquipment(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "AccountsReceivableNetCurrent" Then Receivables(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "InventoryNet" Then Inventory(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "AssetsCurrent" Then AssetsCurrent(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "Assets" Then Assets(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "LiabilitiesCurrent" Then LiabilitiesCurrent(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "Liabilities" Then Liabilities(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "StockholdersEquity" Then Equity(1, 1) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If If Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Left(Row_BS, 7) = "us-gaap" Then If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "CashAndCashEquivalentsAtCarryingValue" Then CashAndCashEquivalents(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "PropertyPlantAndEquipmentNet" Then PropertyPlantEquipment(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "AccountsReceivableNetCurrent" Then Receivables(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "InventoryNet" Then Inventory(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "AssetsCurrent" Then AssetsCurrent(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "Assets" Then Assets(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "LiabilitiesCurrent" Then LiabilitiesCurrent(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "Liabilities" Then Liabilities(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_BS, Len(Row_BS) - InStr(Row_BS, "_")) = "StockholdersEquity" Then Equity(1, 2) = Row_BS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If Next End If End If ' Statement of Income If Tabelle3.Cells(2, 2).Value <> "" Then For Each Row_IS In List_IS If InStr(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, "[unit:iso4217:USD]") > 0 Then intCurrenyIS = intCurrenyIS + 1 End If If Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) End If If Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Left(Row_IS, 7) = "us-gaap" And Tabelle3.Cells(2, 2) <> "" Then If Tabelle1.Cells(21, 5) = Tabelle3.Cells(3, 16) Then If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "SalesRevenueNet" Or Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "Revenues" Then Revenues(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "CostOfGoodsSold" Then CostofGoodsSold(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "CostOfServices" Then CostOfServices(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "CostOfGoodsAndServicesSold" Then CostOfGoodsAndServicesSold(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "GrossProfit" Then GrossProfit(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "OperatingIncomeLoss" Then OperatingIncome(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "NetIncomeLoss" Or Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "ProfitLoss" Then NetIncome(1, 1) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If End If If Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Left(Row_IS, 7) = "us-gaap" And Tabelle3.Cells(2, 2) <> "" Then If Tabelle1.Cells(21, 5) = Tabelle3.Cells(3, 16) Then If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "SalesRevenueNet" Or Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "Revenues" Then Revenues(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "CostOfGoodsSold" Then CostofGoodsSold(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "CostOfServices" Then CostOfServices(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "CostOfGoodsAndServicesSold" Then CostOfGoodsAndServicesSold(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "GrossProfit" Then GrossProfit(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "OperatingIncomeLoss" Then OperatingIncome(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "NetIncomeLoss" Or Right(Row_IS, Len(Row_IS) - InStr(Row_IS, "_")) = "ProfitLoss" Then NetIncome(1, 2) = Row_IS.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If End If Next End If ' Statement of Comprehensive Income If Tabelle4.Cells(2, 2).Value <> "" Then For Each Row_CI In List_CI If InStr(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, "[unit:iso4217:USD]") > 0 Then intCurrenyCI = intCurrenyCI + 1 End If If Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) End If If Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Left(Row_CI, 7) = "us-gaap" And Tabelle3.Cells(2, 2) = "" Then If Tabelle1.Cells(21, 5) = Tabelle4.Cells(3, 16) Then If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "SalesRevenueNet" Or Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "Revenues" Then Revenues(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "CostOfGoodsSold" Then CostofGoodsSold(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "CostOfServices" Then CostOfServices(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "CostOfGoodsAndServicesSold" Then CostOfGoodsAndServicesSold(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "GrossProfit" Then GrossProfit(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "OperatingIncomeLoss" Then OperatingIncome(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "NetIncomeLoss" Or Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "ProfitLoss" Then NetIncome(1, 1) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If End If If Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Left(Row_CI, 7) = "us-gaap" And Tabelle3.Cells(2, 2) = "" Then If Tabelle1.Cells(21, 5) = Tabelle4.Cells(3, 16) Then If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "SalesRevenueNet" Or Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "Revenues" Then Revenues(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "CostOfGoodsSold" Then CostofGoodsSold(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "CostOfServices" Then CostOfServices(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "CostOfGoodsAndServicesSold" Then CostOfGoodsAndServicesSold(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "GrossProfit" Then GrossProfit(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "OperatingIncomeLoss" Then OperatingIncome(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If If Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "NetIncomeLoss" Or Right(Row_CI, Len(Row_CI) - InStr(Row_CI, "_")) = "ProfitLoss" Then NetIncome(1, 2) = Row_CI.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If End If Next End If ' Statement of Cash flows If Tabelle5.Cells(2, 2).Value <> "" Then For Each Row_CF In List_CF If InStr(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, "[unit:iso4217:USD]") > 0 Then intCurrenyCF = intCurrenyCF + 1 End If If Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) End If If Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Tabelle1.Cells(21, 5) = Tabelle5.Cells(3, 16) Then If Right(Row_CF, Len(Row_CF) - InStr(Row_CF, "_")) = "NetCashProvidedByUsedInOperatingActivities" Or Right(Row_CF, Len(Row_CF) - InStr(Row_CF, "_")) = "NetCashProvidedByUsedInOperatingActivitiesContinuingOperations" Then If Left(Row_CF, 7) = "us-gaap" Then OCF(1, 1) = Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If End If If Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next <> "" Then Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next = Left(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, InStr(Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next, " [") - 1) If Tabelle1.Cells(21, 5) = Tabelle5.Cells(3, 16) Then If Right(Row_CF, Len(Row_CF) - InStr(Row_CF, "_")) = "NetCashProvidedByUsedInOperatingActivities" Or Right(Row_CF, Len(Row_CF) - InStr(Row_CF, "_")) = "NetCashProvidedByUsedInOperatingActivitiesContinuingOperations" Then If Left(Row_CF, 7) = "us-gaap" Then OCF(1, 2) = Row_CF.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next.Next End If End If End If End If Next End If 'Clear & Format Statement Sheets Tabelle2.Columns("E:O").Delete Tabelle2.Columns("G:T").Delete Tabelle2.Columns("A:A").ClearContents Tabelle2.Columns("E:F").ColumnWidth = 20 Tabelle2.Range("E3:F3") = "" Tabelle3.Columns("E:O").Delete Tabelle3.Columns("H:K").Delete Tabelle3.Columns("A:A").ClearContents Tabelle3.Columns("E:G").ColumnWidth = 20 Tabelle4.Columns("E:O").Delete Tabelle4.Columns("H:K").Delete Tabelle4.Columns("A:A").ClearContents Tabelle4.Columns("E:G").ColumnWidth = 20 Tabelle5.Columns("E:O").Delete Tabelle5.Columns("H:K").Delete Tabelle5.Columns("A:A").ClearContents Tabelle5.Columns("E:G").ColumnWidth = 20 If Tabelle2.Cells(2, 2) = "" Or Tabelle2.Cells(1, 5) = "" Then Tabelle2.Columns("A:D").ClearContents Tabelle2.Cells(2, 2) = "NA" End If If Tabelle3.Cells(2, 2) = "" Or Tabelle3.Cells(2, 5) = "" Then Tabelle3.Columns("A:D").ClearContents Tabelle3.Cells(2, 2) = "NA" End If If Tabelle4.Cells(2, 2) = "" Or Tabelle4.Cells(2, 5) = "" Then Tabelle4.Columns("A:D").ClearContents Tabelle4.Cells(2, 2) = "NA" End If If Tabelle5.Cells(2, 2) = "" Or Tabelle5.Cells(2, 5) = "" Then Tabelle5.Columns("A:D").ClearContents Tabelle5.Cells(2, 2) = "NA" End If ' Currency Check If Tabelle2.Cells(1, 5) <> "" And intCurrenyBS > 0 Then Tabelle2.Cells(4, 5) = "USD ($)" Tabelle2.Cells(4, 5).HorizontalAlignment = xlRight End If If Tabelle2.Cells(1, 6) <> "" And intCurrenyBS > 0 Then Tabelle2.Cells(4, 6) = "USD ($)" Tabelle2.Cells(4, 6).HorizontalAlignment = xlRight End If If Tabelle3.Cells(2, 5) <> "" And intCurrenyIS > 0 Then Tabelle3.Cells(4, 5) = "USD ($)" Tabelle3.Cells(4, 5).HorizontalAlignment = xlRight End If If Tabelle3.Cells(2, 6) <> "" And intCurrenyIS > 0 Then Tabelle3.Cells(4, 6) = "USD ($)" Tabelle3.Cells(4, 6).HorizontalAlignment = xlRight End If If Tabelle3.Cells(2, 7) <> "" And intCurrenyIS > 0 Then Tabelle3.Cells(4, 7) = "USD ($)" Tabelle3.Cells(4, 7).HorizontalAlignment = xlRight End If If Tabelle4.Cells(2, 5) <> "" And intCurrenyCI > 0 Then Tabelle4.Cells(4, 5) = "USD ($)" Tabelle4.Cells(4, 5).HorizontalAlignment = xlRight End If If Tabelle4.Cells(2, 6) <> "" And intCurrenyCI > 0 Then Tabelle4.Cells(4, 6) = "USD ($)" Tabelle4.Cells(4, 6).HorizontalAlignment = xlRight End If If Tabelle4.Cells(2, 7) <> "" And intCurrenyCI > 0 Then Tabelle4.Cells(4, 7) = "USD ($)" Tabelle4.Cells(4, 7).HorizontalAlignment = xlRight End If If Tabelle5.Cells(2, 5) <> "" And intCurrenyCF > 0 Then Tabelle5.Cells(4, 5) = "USD ($)" Tabelle5.Cells(4, 5).HorizontalAlignment = xlRight End If If Tabelle5.Cells(2, 6) <> "" And intCurrenyCF > 0 Then Tabelle5.Cells(4, 6) = "USD ($)" Tabelle5.Cells(4, 6).HorizontalAlignment = xlRight End If If Tabelle5.Cells(2, 7) <> "" And intCurrenyCF > 0 Then Tabelle5.Cells(4, 7) = "USD ($)" Tabelle5.Cells(4, 7).HorizontalAlignment = xlRight End If 'Ratio Calculation If CashAndCashEquivalents(1, 1) <> "" And Assets(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(26, 4) = CashAndCashEquivalents(1, 1) / Assets(1, 1) End If If CashAndCashEquivalents(1, 2) <> "" And Assets(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(26, 5) = CashAndCashEquivalents(1, 2) / Assets(1, 2) End If If PropertyPlantEquipment(1, 1) <> "" And Assets(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(28, 4) = PropertyPlantEquipment(1, 1) / Assets(1, 1) End If If PropertyPlantEquipment(1, 2) <> "" And Assets(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(28, 5) = PropertyPlantEquipment(1, 2) / Assets(1, 2) End If If Receivables(1, 1) <> "" And Assets(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(30, 4) = Receivables(1, 1) / Assets(1, 1) End If If Receivables(1, 2) <> "" And Assets(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(30, 5) = Receivables(1, 2) / Assets(1, 2) End If If Inventory(1, 1) <> "" And Assets(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(32, 4) = Inventory(1, 1) / Assets(1, 1) End If If Inventory(1, 2) <> "" And Assets(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(32, 5) = Inventory(1, 2) / Assets(1, 2) End If If NetIncome(1, 1) <> "" And Assets(1, 1) <> "" And OCF(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(34, 4) = (Val(NetIncome(1, 1)) - Val(OCF(1, 1))) / Assets(1, 1) End If If NetIncome(1, 2) <> "" And Assets(1, 2) <> "" And OCF(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(34, 5) = (Val(NetIncome(1, 2)) - Val(OCF(1, 2))) / Assets(1, 2) End If If Equity(1, 1) <> "" And Assets(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(36, 4) = Equity(1, 1) / Assets(1, 1) End If If Equity(1, 2) <> "" And Assets(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(36, 5) = Equity(1, 2) / Assets(1, 2) End If If CostofGoodsSold(1, 1) <> "" Or CostOfServices(1, 1) <> "" Then If Inventory(1, 1) <> "" And Val(Inventory(1, 1)) <> "0" Then Tabelle1.Cells(40, 4) = (Val(CostofGoodsSold(1, 1)) + Val(CostOfServices(1, 1))) / Inventory(1, 1) End If End If If CostofGoodsSold(1, 2) <> "" Or CostOfServices(1, 2) <> "" Then If Inventory(1, 2) <> "" And Val(Inventory(1, 2)) <> "0" Then Tabelle1.Cells(40, 5) = (Val(CostofGoodsSold(1, 2)) + Val(CostOfServices(1, 2))) / Inventory(1, 2) End If End If If CostOfGoodsAndServicesSold(1, 1) <> "" And Inventory(1, 1) <> "" And Val(Inventory(1, 1)) <> "0" Then Tabelle1.Cells(40, 4) = CostOfGoodsAndServicesSold(1, 1) / Inventory(1, 1) End If If CostOfGoodsAndServicesSold(1, 2) <> "" And Inventory(1, 2) <> "" And Val(Inventory(1, 2)) <> "0" Then Tabelle1.Cells(40, 5) = CostOfGoodsAndServicesSold(1, 2) / Inventory(1, 2) End If If Revenues(1, 1) <> "" And Receivables(1, 1) <> "" And Val(Receivables(1, 1)) <> "0" Then Tabelle1.Cells(42, 4) = Revenues(1, 1) / Receivables(1, 1) End If If Revenues(1, 2) <> "" And Receivables(1, 2) <> "" And Val(Receivables(1, 2)) <> "0" Then Tabelle1.Cells(42, 5) = Revenues(1, 2) / Receivables(1, 2) End If If Revenues(1, 1) <> "" And AssetsCurrent(1, 1) <> "" And LiabilitiesCurrent(1, 1) <> "" Then If AssetsCurrent(1, 1) - LiabilitiesCurrent(1, 1) <> "0" Then Tabelle1.Cells(44, 4) = Revenues(1, 1) / (Val(AssetsCurrent(1, 1)) - Val(LiabilitiesCurrent(1, 1))) End If End If If Revenues(1, 2) <> "" And AssetsCurrent(1, 2) <> "" And LiabilitiesCurrent(1, 2) <> "" Then If AssetsCurrent(1, 2) - LiabilitiesCurrent(1, 2) <> "0" Then Tabelle1.Cells(44, 5) = Revenues(1, 2) / (Val(AssetsCurrent(1, 2)) - Val(LiabilitiesCurrent(1, 2))) End If End If If Revenues(1, 1) <> "" And Assets(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(46, 4) = Revenues(1, 1) / Assets(1, 1) End If If Revenues(1, 2) <> "" And Assets(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(46, 5) = Revenues(1, 2) / Assets(1, 2) End If If AssetsCurrent(1, 1) <> "" And LiabilitiesCurrent(1, 1) <> "" And Val(LiabilitiesCurrent(1, 1)) <> "0" Then Tabelle1.Cells(50, 4) = AssetsCurrent(1, 1) / LiabilitiesCurrent(1, 1) End If If AssetsCurrent(1, 2) <> "" And LiabilitiesCurrent(1, 2) <> "" And Val(LiabilitiesCurrent(1, 2)) <> "0" Then Tabelle1.Cells(50, 5) = AssetsCurrent(1, 2) / LiabilitiesCurrent(1, 2) End If If CashAndCashEquivalents(1, 1) <> "" And LiabilitiesCurrent(1, 1) <> "" And Val(LiabilitiesCurrent(1, 1)) <> "0" Then Tabelle1.Cells(52, 4) = CashAndCashEquivalents(1, 1) / LiabilitiesCurrent(1, 1) End If If CashAndCashEquivalents(1, 2) <> "" And LiabilitiesCurrent(1, 2) <> "" And Val(LiabilitiesCurrent(1, 2)) <> "0" Then Tabelle1.Cells(52, 5) = CashAndCashEquivalents(1, 2) / LiabilitiesCurrent(1, 2) End If If Liabilities(1, 1) <> "" And Equity(1, 1) <> "" And Val(Equity(1, 1)) <> "0" Then Tabelle1.Cells(54, 4) = Liabilities(1, 1) / Equity(1, 1) End If If Liabilities(1, 2) <> "" And Equity(1, 2) <> "" And Val(Equity(1, 2)) <> "0" Then Tabelle1.Cells(54, 5) = Liabilities(1, 2) / Equity(1, 2) End If If Revenues(1, 1) <> "" And Val(Revenues(1, 1)) <> "0" And GrossProfit(1, 1) <> "" Then Tabelle1.Cells(58, 4) = GrossProfit(1, 1) / Revenues(1, 1) End If If Revenues(1, 2) <> "" And Val(Revenues(1, 2)) <> "0" And GrossProfit(1, 2) <> "" Then Tabelle1.Cells(58, 5) = GrossProfit(1, 2) / Revenues(1, 2) End If If Revenues(1, 1) <> "" And Val(Revenues(1, 1)) <> "0" And OperatingIncome(1, 1) <> "" Then Tabelle1.Cells(60, 4) = OperatingIncome(1, 1) / Revenues(1, 1) End If If Revenues(1, 2) <> "" And Val(Revenues(1, 2)) <> "0" And OperatingIncome(1, 2) <> "" Then Tabelle1.Cells(60, 5) = OperatingIncome(1, 2) / Revenues(1, 2) End If If Revenues(1, 1) <> "" And Val(Revenues(1, 1)) <> "0" And NetIncome(1, 1) <> "" Then Tabelle1.Cells(62, 4) = NetIncome(1, 1) / Revenues(1, 1) End If If Revenues(1, 2) <> "" And Val(Revenues(1, 2)) <> "0" And NetIncome(1, 2) <> "" Then Tabelle1.Cells(62, 5) = NetIncome(1, 2) / Revenues(1, 2) End If If Assets(1, 1) <> "" And NetIncome(1, 1) <> "" And Val(Assets(1, 1)) <> "0" Then Tabelle1.Cells(64, 4) = NetIncome(1, 1) / Assets(1, 1) End If If Assets(1, 2) <> "" And NetIncome(1, 2) <> "" And Val(Assets(1, 2)) <> "0" Then Tabelle1.Cells(64, 5) = NetIncome(1, 2) / Assets(1, 2) End If If Equity(1, 1) <> "" And Val(Equity(1, 1)) <> "0" And NetIncome(1, 1) <> "" Then Tabelle1.Cells(66, 4) = NetIncome(1, 1) / Equity(1, 1) End If If Equity(1, 2) <> "" And Val(Equity(1, 2)) <> "0" And NetIncome(1, 2) <> "" Then Tabelle1.Cells(66, 5) = NetIncome(1, 2) / Equity(1, 2) End If End Sub
Sub ClearContents() Tabelle1.Cells(19, 2).ClearContents Tabelle1.Cells(19, 3).ClearContents Tabelle1.Cells(19, 4).ClearContents Tabelle1.Cells(19, 5).ClearContents Tabelle1.Cells(19, 6).ClearContents Tabelle1.Cells(21, 2).ClearContents Tabelle1.Cells(21, 3).ClearContents Tabelle1.Cells(21, 4).ClearContents Tabelle1.Cells(21, 5).ClearContents Tabelle1.Cells(21, 6).ClearContents Tabelle1.Cells(26, 4).ClearContents Tabelle1.Cells(26, 5).ClearContents Tabelle1.Cells(28, 4).ClearContents Tabelle1.Cells(28, 5).ClearContents Tabelle1.Cells(30, 4).ClearContents Tabelle1.Cells(30, 5).ClearContents Tabelle1.Cells(32, 4).ClearContents Tabelle1.Cells(32, 5).ClearContents Tabelle1.Cells(34, 4).ClearContents Tabelle1.Cells(34, 5).ClearContents Tabelle1.Cells(36, 4).ClearContents Tabelle1.Cells(36, 5).ClearContents Tabelle1.Cells(40, 4).ClearContents Tabelle1.Cells(40, 5).ClearContents Tabelle1.Cells(42, 4).ClearContents Tabelle1.Cells(42, 5).ClearContents Tabelle1.Cells(44, 4).ClearContents Tabelle1.Cells(44, 5).ClearContents Tabelle1.Cells(46, 4).ClearContents Tabelle1.Cells(46, 5).ClearContents Tabelle1.Cells(50, 4).ClearContents Tabelle1.Cells(50, 5).ClearContents Tabelle1.Cells(52, 4).ClearContents Tabelle1.Cells(52, 5).ClearContents Tabelle1.Cells(54, 4).ClearContents Tabelle1.Cells(54, 5).ClearContents Tabelle1.Cells(58, 4).ClearContents Tabelle1.Cells(58, 5).ClearContents Tabelle1.Cells(60, 4).ClearContents Tabelle1.Cells(60, 5).ClearContents Tabelle1.Cells(62, 4).ClearContents Tabelle1.Cells(62, 5).ClearContents Tabelle1.Cells(64, 4).ClearContents Tabelle1.Cells(64, 5).ClearContents Tabelle1.Cells(66, 4).ClearContents Tabelle1.Cells(66, 5).ClearContents Sheets("BS").Cells.ClearContents Sheets("IS").Cells.ClearContents Sheets("CI").Cells.ClearContents Sheets("CF").Cells.ClearContents End Sub
Option Explicit Enum SortType xlAscending xlDescending End Enum Public arrStatement2 Public arrContextListUnique Public uniqueNumbers As Integer