'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''' USER INPUTS (1/2): '''''''''''''''''''''''''''''''''''''''' '''' Dieses Umbenennungsschema am Kunden anpassen! ''''''''''''' Private Function campaignnamenUmbenennung(nom As String) As String '#If Mac Then '#Else '#End If On Error GoTo Err Dim REGEX As Object Set REGEX = CreateObject("VBScript.RegExp") REGEX.Pattern = "^\s*(.*\S|)\s*-\s*(BW|BY|BE|BB|HB|HH|HE|MV|NI|NW|RP|SL|SN|ST|SH|TH)\s*-\s*(.*\S|)\s*$" ' REGEX.Global = True REGEX.IgnoreCase = True campaignnamenUmbenennung = nom If (REGEX.Test(nom)) Then: campaignnamenUmbenennung = REGEX.Replace(nom, "$2-$1-$3") Exit Function Err: '' Auf VBA für MAC OSX wird Regex noch nicht unterstützt (2018) '' Schema für MAC OSX: Dim key As Variant campaignnamenUmbenennung = nom For Each key In Array("BW", "BY", "BE", "BB", "HB", "HH", "HE", "MV", "NI", "NW", "RP", "SL", "SN", "ST", "SH", "TH") If nom Like "*- " & CStr(key) & " -*" Then campaignnamenUmbenennung = CStr(key) & " - " & nom Exit For End If Next key End Function '''' Schema zum Headline-Kombinieren anpassen! ''''''''''''' Private Function combineheadlines(h1 As String, h2 As String) As String combineheadlines = h1 & " - " & h2 End Function '''' ENDE VON USER INPUTS. ''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Function MAXSHEETNAMELENGTH() As Integer MAXSHEETNAMELENGTH = 31 '' Konstante wird von VBA festgelegt End Function '' HAUPTVORGANG Sub lesbarerBericht() Dim blatt As String Dim blatt_namespace As New Collection Dim blatt_raw As New Collection Dim blatt_kw As New Collection Dim blatt_sitelink As New Collection Dim blatt_callout As New Collection Dim blatt_snippet As New Collection blatt_raw.Add key:="spalte", Item:=New Collection blatt_kw.Add key:="spalte", Item:=New Collection blatt_namespace.Add key:="spalte", Item:=New Collection blatt_sitelink.Add key:="spalte", Item:=New Collection blatt_callout.Add key:="spalte", Item:=New Collection blatt_snippet.Add key:="spalte", Item:=New Collection Dim sheetname As String Dim sheetIdx As Integer Dim sheetlist As New Collection Dim RGB_alert As Long Dim RGB_c As Long Dim RGB_adgroup As Long Dim campaignName As String Dim campaign As String Dim adgroupName As String Dim adgroups As Collection Dim adgroup As String Dim stAttrib As New Collection With stAttrib .Add key:="keys", Item:=Array("c", "adgroup") .Add key:="name", Item:=New Collection End With Dim kwAttrib As New Collection With kwAttrib .Add key:="keys", Item:=Array("kw") .Add key:="name", Item:=New Collection End With Dim adAttrib As New Collection With adAttrib .Add key:="name", Item:=New Collection .Add key:="maxlength", Item:=New Collection End With Dim sitelinkAttrib As New Collection With sitelinkAttrib .Add key:="name", Item:=New Collection .Add key:="maxlength", Item:=New Collection End With Dim calloutAttrib As New Collection With calloutAttrib .Add key:="name", Item:=New Collection .Add key:="maxlength", Item:=New Collection End With Dim snippetAttrib As New Collection With snippetAttrib .Add key:="name", Item:=New Collection .Add key:="maxlength", Item:=New Collection End With Dim snips As New Collection Dim snippets_sepchar As New Collection Dim snippets_joinchar As String Dim namespaceAttrib As New Collection With namespaceAttrib .Add key:="keys", Item:=Array("c", "um", "sheetname", "show", "delete", "adgroup", "ads", "kw", "progress") .Add key:="name", Item:=New Collection .Add key:="map", Item:=New Collection .Add key:="delete", Item:=New Collection End With Dim anzahlEntriesProAdgruppe As Integer Dim Zoomfaktor As Integer Dim Startzeile As Integer Dim ZeileIdx As Integer Dim ZeilenPerAd As Integer Dim ZeilenPerSitelink As Integer Dim SpalteIdx As Integer Dim SpaltenZwAdgroups As Integer Dim SpaltenbreiteAdgroup As Integer Dim SpaltenbreiteCampaign As Integer Dim zelle As Range Dim key_str As String Dim key As Variant Dim key1 As Variant Dim key2 As Variant Dim key_c As Variant Dim key_adgroup As Variant Dim key_ad As Variant Dim s As Integer Dim n As Integer Dim anzahl_adgroups As Integer Dim anzahl_ads As Integer Dim anzahl_kw As Integer Dim dummy As Variant Dim i As Integer Dim j As Integer Dim j1 As Integer Dim j2 As Integer Dim j_c As Integer Dim j_adgroup As Integer Dim finalurl As Variant Dim val As Variant Dim kw As String Dim bool As Boolean Dim bool_c As Boolean Dim bool_alt As Boolean Dim addr As String Dim addr1 As String Dim addr2 As String Dim sformula As String Dim maxlen As Integer Dim maxlen1 As Integer Dim maxlen2 As Integer Dim ZeileAds As New Collection With ZeileAds For Each key In Array("ads","kw","sitelink","callout","snippet","sitelink_c","callout_c","snippet_c") .Add key:=key, Item:=New Collection .Item(key).Add key:="start", Item:=New Collection .Item(key).Add key:="end", Item:=New Collection Next End With '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''' USER INPUTS (2/2): GGF. ANPASSEN!! '''''''''''''''''''''''' Zoomfaktor = 125 '' NAME DER INPUTDATENSHEETS: blatt_namespace.Add key:="name", Item:="Index" blatt_raw.Add key:="name", Item:="RawDaten" blatt_kw.Add key:="name", Item:="Keywords" blatt_sitelink.Add key:="name", Item:="Sitelinks" blatt_callout.Add key:="name", Item:="Callouts" blatt_snippet.Add key:="name", Item:="Snippets" '' STANDARDSPALTEN: With stAttrib .Item("name").Add key:="c", Item:="Campaign" .Item("name").Add key:="adgroup", Item:="Ad Group" End With kwAttrib.Item("name").Add key:="kw", Item:="Keyword" '' ADS With adAttrib '' SPALTEN FÜR ABZULESENDE ATTRIBUTE: .Add key:="keys", Item:=Array("head1", "head2", "url", "descr", "finalurl") With .Item("name") .Add key:="head1", Item:="Headline 1" .Add key:="head2", Item:="Headline 2" .Add key:="url", Item:="Display URL" .Add key:="descr", Item:="Description" .Add key:="finalurl", Item:="Final URL" End With '' MAXZEICHENLÄNGEN: With .Item("maxlength") .Add key:="head1", Item:=30 .Add key:="head2", Item:=30 .Add key:="head", Item:=30 + 30 + 3 .Add key:="descr", Item:=80 End With End With '' SITELINKS With sitelinkAttrib '' SPALTEN FÜR ABZULESENDE ATTRIBUTE: .Add key:="keys", Item:=Array("feed", "text", "line1", "line2", "finalurl") With .Item("name") .Add key:="feed", Item:="Feed Name" .Add key:="text", Item:="Link Text" .Add key:="line1", Item:="Description Line 1" .Add key:="line2", Item:="Description Line 2" .Add key:="finalurl", Item:="Final URL" End With '' MAXZEICHENLÄNGEN: With .Item("maxlength") .Add key:="text", Item:=25 .Add key:="line1", Item:=35 .Add key:="line2", Item:=35 End With End With '' CALLOUTS With calloutAttrib '' SPALTEN FÜR ABZULESENDE ATTRIBUTE: .Add key:="keys", Item:=Array("feed", "text") With .Item("name") .Add key:="feed", Item:="Feed Name" .Add key:="text", Item:="Callout text" End With '' MAXZEICHENLÄNGEN: With .Item("maxlength") .Add key:="text", Item:=25 End With End With '' SNIPPETS With snippetAttrib '' SPALTEN FÜR ABZULESENDE ATTRIBUTE: .Add key:="keys", Item:=Array("feed", "head", "snippet") With .Item("name") .Add key:="feed", Item:="Feed Name" .Add key:="head", Item:="Header" .Add key:="snippet", Item:="Snippet Values" End With '' MAXZEICHENLÄNGEN: With .Item("maxlength") .Add key:="snippet", Item:=25 End With End With With snippets_sepchar .Add ";" ' CSV-Separator .Add Chr(10) ' Windows Zeilenumbruch .Add Chr(13) ' Mac Zeilenumbruch End With snippets_joinchar = ";" '' INDEX/NAMESPACE-SPALTEN: With namespaceAttrib.Item("name") .Add key:="c", Item:="Campaign" .Add key:="um", Item:="* Umbenennung" .Add key:="sheetname", Item:="Blattname" .Add key:="show", Item:="* Aktualisieren?" .Add key:="delete", Item:="* Entfernen?" .Add key:="adgroup", Item:="#Adgruppen" .Add key:="ads", Item:="#Ads/Adgr. (Ø)" .Add key:="kw", Item:="#Kw/Adgr. (Ø)" .Add key:="progress", Item:="#Fortschritt" End With '' LAYOUTOPTIONEN FÜR REPORTS RGB_c = RGB(217, 225, 242) '' Hervorhebungsfarbe für Kampagnennamen RGB_adgroup = RGB(231, 230, 230) '' Alternierende Hervorhebungsfarbe für Adgruppen RGB_alert = RGB(255, 99, 71) '' Hervorhebungsfarbe, für Warnung (Zeichenkette zu lange) Startzeile = 2 '' Startzeile im lesbaren Bericht SpaltenZwAdgroups = 1 '''' ENDE VON USER INPUTS. ''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''' AB HIER ÜBERNIMMT DER CODE DEN REST!! '''' '' PRÜFE SHEETS If Not checkSheet(blatt_raw, stAttrib, adAttrib) Then: Exit Sub If Not checkSheet(blatt_kw, stAttrib, kwAttrib) Then: Exit Sub If Not checkSheet(blatt_sitelink, stAttrib, sitelinkAttrib) Then: Exit Sub If Not checkSheet(blatt_callout, stAttrib, calloutAttrib) Then: Exit Sub If Not checkSheet(blatt_snippet, stAttrib, snippetAttrib) Then: Exit Sub '' NAMESPACE EINRICHTEN Dim neu As Boolean sheetname = blatt_namespace.Item("name") neu = Not existiertBlatt(sheetname) If Not createNamespace(blatt_namespace, namespaceAttrib, 1) Then: Exit Sub Application.ScreenUpdating = False If neu Then Dim src As New Collection With src .Add blatt_raw .Add blatt_kw .Add blatt_sitelink .Add blatt_callout .Add blatt_snippet End With Call setupNamespace(blatt_namespace, namespaceAttrib, src, "c", "um", "sheetname", "show", "delete") Sheets(blatt_namespace.Item("name")).Select Application.ScreenUpdating = True MsgBox ("Bitte, im »" & blatt_namespace.Item("name") & "« Blatt die Kampagnennamen umbenennen, dann dieses Skript nochmals ausführen!") Exit Sub Else Application.ScreenUpdating = True Call mapNamespace(blatt_namespace, namespaceAttrib, "c", "um", "sheetname", "show", "delete") End If Sheets(blatt_namespace.Item("name")).Select '' ENTFERNE ALTE BLÄTTER If Not removeOldReports(namespaceAttrib.Item("delete")) Then: Exit Sub '' SCHLEIFE DURCH ROHE DATEN sheetname = "" j_c = blatt_raw.Item("spalte").Item("c") j_adgroup = blatt_raw.Item("spalte").Item("adgroup") ZeilenPerAd = adAttrib.Item("name").Count - 2 '' -1 weil Head1 & Head2 auf einer Zeile erscheinen; und Final URL nur 1 Mal verwendet wird. ZeilenPerSitelink = sitelinkAttrib.Item("name").Count - 1 '' -1 weil Feed-Typ ausgeschlossen wird. SpaltenbreiteAdgroup = 2 + 3 + SpaltenZwAdgroups '' jede Adgroup belegt 2 Spalten für Text + 2 für Counts + 1 für Fehlermeldung + Platzzw. Adgroups i = 2 sheetIdx = 0 Application.ScreenUpdating = False Application.DisplayAlerts = False For Each key_c In namespaceAttrib.Item("map").Item("keys") campaign = CStr(key_c) sheetname = namespaceAttrib.Item("map").Item("values").Item(key_c).Item("sheetname") If campaign <> "" Then '' SAMMLE DATEN ÜBER ADGRUPPEN (ADS + KEYWORDS) Set adgroups = getAdgroupData(campaign, blatt_raw, blatt_kw, blatt_sitelink, blatt_callout, blatt_snippet) bool_c = False '' ERSTELLE BLATT FÜR CAMPAIGN ZeileIdx = Startzeile s = ActiveWorkbook.Sheets.Count If existiertBlatt(sheetname) Then s = Sheets(sheetname).Index Sheets(sheetname).Delete End If Call createBlatt(sheetname, True, ActiveWorkbook.Sheets.Count) sheetlist.Add sheetname sheetIdx = sheetIdx + 1 SpalteIdx = 2 With Sheets(sheetname) anzahl_adgroups = adgroups.Item("ads").Item("keys").Count ' anzahl_adgroups = adgroups.value("ads").value("data").Length SpaltenbreiteCampaign = anzahl_adgroups * SpaltenbreiteAdgroup '' - SpaltenZwAdgroups If SpaltenbreiteCampaign < 1 Then: SpaltenbreiteCampaign = 1 With .Cells(Startzeile-1, SpalteIdx) .Formula = "=HYPERLINK(""#'" & blatt_namespace.Item("name") & "'!A1"", ""(Link zu Inhaltsverzeichnis)"")" .Font.Bold = True End With With .Cells(Startzeile, SpalteIdx) .value = campaign .Font.Bold = True .Interior.Color = RGB_c End With .Range(.Cells(Startzeile, SpalteIdx), .Cells(Startzeile, SpalteIdx + SpaltenbreiteCampaign - 1)).Merge '' Alles anzeigen: .UsedRange.Columns.EntireColumn.Hidden = False .UsedRange.Rows.EntireRow.Hidden = False '' SETZE ZEILENPOSITIONEN VON ADS + KEYWORDS ZeileIdx = Startzeile + 4 anzahlEntriesProAdgruppe = adgroups.Item("maxcount_ads") ZeileAds.Item("ads").Item("start").Add ZeileIdx If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe * (ZeilenPerAd + 1) + 2 - 1 '' 2 Zeilen für Final URL ZeileAds.Item("ads").Item("end").Add ZeileIdx ZeileIdx = ZeileAds.Item("ads").Item("end")(sheetIdx) + 3 ZeileAds.Item("kw").Item("start").Add ZeileIdx ZeileAds.Item("kw").Item("end").Add ZeileIdx ' ADGRUPPENEBENE-ERWEITERUNGEN ZeileIdx = ZeileAds.Item("kw").Item("end")(sheetIdx) + 2 ZeileAds.Item("sitelink").Item("start").Add ZeileIdx anzahlEntriesProAdgruppe = adgroups.Item("maxcount_sitelink") If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe * (ZeilenPerSitelink + 1) - 1 ZeileAds.Item("sitelink").Item("end").Add ZeileIdx ZeileIdx = ZeileAds.Item("sitelink").Item("end")(sheetIdx) + 2 ZeileAds.Item("callout").Item("start").Add ZeileIdx anzahlEntriesProAdgruppe = adgroups.Item("maxcount_callout") If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe ZeileAds.Item("callout").Item("end").Add ZeileIdx ZeileIdx = ZeileAds.Item("callout").Item("end")(sheetIdx) + 2 ZeileAds.Item("snippet").Item("start").Add ZeileIdx anzahlEntriesProAdgruppe = adgroups.Item("maxcount_snippet") If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe ZeileAds.Item("snippet").Item("end").Add ZeileIdx ' CAMPAIGNEBENE-ERWEITERUNGEN ZeileIdx = ZeileAds.Item("snippet").Item("end")(sheetIdx) + 3 ZeileAds.Item("sitelink_c").Item("start").Add ZeileIdx anzahlEntriesProAdgruppe = adgroups.Item("maxcount_sitelink_c") If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe * (ZeilenPerSitelink + 1) - 1 ZeileAds.Item("sitelink_c").Item("end").Add ZeileIdx ZeileIdx = ZeileAds.Item("sitelink_c").Item("end")(sheetIdx) + 2 ZeileAds.Item("callout_c").Item("start").Add ZeileIdx anzahlEntriesProAdgruppe = adgroups.Item("maxcount_callout_c") If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe ZeileAds.Item("callout_c").Item("end").Add ZeileIdx ZeileIdx = ZeileAds.Item("callout_c").Item("end")(sheetIdx) + 2 ZeileAds.Item("snippet_c").Item("start").Add ZeileIdx anzahlEntriesProAdgruppe = adgroups.Item("maxcount_snippet_c") If anzahlEntriesProAdgruppe > 0 Then ZeileIdx = ZeileIdx - 1 + anzahlEntriesProAdgruppe ZeileAds.Item("snippet_c").Item("end").Add ZeileIdx '' FRIERE SPALTE / ZEILE ZeileIdx = ZeileAds.Item("ads").Item("start")(sheetIdx) - 1 .Select With ActiveWindow .FreezePanes = False .Zoom = Zoomfaktor .SplitColumn = 1 .SplitRow = ZeileIdx .FreezePanes = True End With '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' SCHLEIFE DURCH ADGRUPPEN—WERTE EXTRAHIEREN: ''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' SpalteIdx = 2 anzahl_ads = 0 anzahl_kw = 0 bool_alt = True For Each key_adgroup In adgroups.Item("ads").Item("keys") adgroup = CStr(key_adgroup) ZeileIdx = Startzeile + 1 With .Cells(ZeileIdx, SpalteIdx) .value = adgroup .Font.Bold = True If bool_alt Then: .Interior.Color = RGB_adgroup End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + SpaltenbreiteAdgroup - 1)).Merge If bool_alt Then: .Range(.Cells(ZeileAds.Item("ads").Item("start")(sheetIdx), SpalteIdx), .Cells(ZeileAds.Item("ads").Item("end")(sheetIdx), SpalteIdx + SpaltenbreiteAdgroup - 1)).Interior.Color = RGB_adgroup bool_alt = Not bool_alt '' STARTE: SCHLEIFE DURCH ADS: ZeileIdx = ZeileAds.Item("ads").Item("start")(sheetIdx) '' TRAGE #ADS EIN n = adgroups.Item("ads").Item("values").Item(adgroup).Count anzahl_ads = anzahl_ads + n With .Cells(ZeileIdx - 1, SpalteIdx) .HorizontalAlignment = xlLeft .value = n End With finalurl = "" For Each key_ad In adgroups.Item("ads").Item("values").Item(adgroup) i = CInt(key_ad) key = "head" key1 = "head1" key2 = "head2" j1 = blatt_raw.Item("spalte").Item(key1) j2 = blatt_raw.Item("spalte").Item(key2) val = combineheadlines(CStr(val1), CStr(val2)) val1 = Sheets(blatt_raw.Item("name")).Cells(i, j1).value val2 = Sheets(blatt_raw.Item("name")).Cells(i, j2).value maxlen1 = adAttrib.Item("maxlength").Item(key1) maxlen2 = adAttrib.Item("maxlength").Item(key2) If Len(val1) > adAttrib.Item("maxlength").Item(key) Then: bool_c = True If Len(val2) > adAttrib.Item("maxlength").Item(key2) Then: bool_c = True '' HEAD 1 With .Cells(ZeileIdx, SpalteIdx) .value = val1 ' addr1 = .Offset(0,2).Address(RowAbsolute:=True, ColumnAbsolute:=True) addr1 = .Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr1 & " > " & maxlen1 & ")" addr1 = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) '' leider kann hier nur eine Englische Formel eingegeben werden, doch dann wird diese nicht interpretiert werden, wenn was Englisches drin steht. ' .ModifyAppliesToRange (addr1) '' relative Formel funktioniert leider nicht .Interior.Color = RGB_alert .StopIfTrue = False End With With .Font .Underline = xlUnderlineStyleSingle .ThemeColor = xlThemeColorAccent1 End With .HorizontalAlignment = xlRight End With '' Counts Head1 With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=LEN(" & addr1 & ")" addr1 = .Address(RowAbsolute:=False, ColumnAbsolute:=False) End With '' HEAD 2 With .Cells(ZeileIdx, SpalteIdx + 1) .value = val2 ' addr2 = .Offset(0,2).Address(RowAbsolute:=True, ColumnAbsolute:=True) addr2 = .Offset(0, 2).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr2 & " > " & maxlen2 & ")" addr2 = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB_alert .StopIfTrue = False End With With .Font .Underline = xlUnderlineStyleSingle .ThemeColor = xlThemeColorAccent1 End With End With '' Counts Head2 With .Cells(ZeileIdx, SpalteIdx + 3) .Formula = "=LEN(" & addr2 & ")" addr2 = .Address(RowAbsolute:=False, ColumnAbsolute:=False) End With '' Fehlermeldung für Head1 / Head2 With .Cells(ZeileIdx, SpalteIdx + 4) .Font.Color = RGB(255, 0, 0) .Formula = _ "=IF(AND(" & addr1 & " > " & maxlen1 & ", " & addr2 & " > " & maxlen2 & ")," _ & "CONCAT((" & addr1 & "-" & maxlen1 & ") & "" | "" & (" & addr2 & "-" & maxlen2 & ") & "" zus. Zeichen"")," _ & "IF(" & addr1 & " > " & maxlen1 & "," _ & "CONCAT((" & addr1 & "-" & maxlen1 & ") & "" | -"" & "" zus. Zeichen"")," _ & "IF(" & addr2 & " > " & maxlen2 & "," _ & "CONCAT(""- | "" & (" & addr2 & "-" & maxlen2 & ") & "" zus. Zeichen"")," _ & """"")))" End With '' URL ZeileIdx = ZeileIdx + 1 key = "url" j = blatt_raw.Item("spalte").Item(key) val = Sheets(blatt_raw.Item("name")).Cells(i, j).value .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Underline = xlUnderlineStyleNone .ThemeColor = xlThemeColorAccent6 .ThemeFont = xlThemeFontMinor .Size = 10 End With End With '' DESCRIPTION ZeileIdx = ZeileIdx + 1 key = "descr" j = blatt_raw.Item("spalte").Item(key) val = Sheets(blatt_raw.Item("name")).Cells(i, j).value maxlen = adAttrib.Item("maxlength").Item(key) If Len(val) > maxlen Then: bool_c = True .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val ' addr = .Offset(0,1).Address(RowAbsolute:=True, ColumnAbsolute:=True) addr = .Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr & " > " & maxlen & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB_alert .StopIfTrue = False End With addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) End With '' Counts Description With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=LEN(" & addr & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) End With '' Fehlermeldung für Description With .Cells(ZeileIdx, SpalteIdx + 4) .Font.Color = RGB(255, 0, 0) .Formula = "=IF(" & addr & " > " & maxlen & ", CONCAT((" & addr & "-" & maxlen & ") & "" zus. Zeichen""), """")" End With '' FINAL URL (Wert einlesen) key = "finalurl" j = blatt_raw.Item("spalte").Item(key) finalurl = Sheets(blatt_raw.Item("name")).Cells(i, j).value ZeileIdx = ZeileIdx + 2 Next key_ad '' ENDE: SCHLEIFE DURCH ADS. '' FINAL URL (Wert darstellen) val = finalurl ZeileIdx = ZeileAds.Item("ads").Item("end")(sheetIdx) With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Bold = True .ThemeColor = xlThemeColorAccent6 .ThemeFont = xlThemeFontMinor .Underline = xlUnderlineStyleNone End With End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge '' KEYWORDS: n = adgroups.Item("kw").Item("values").Item(adgroup).Count anzahl_kw = anzahl_kw + n val = "—" If n > 0 Then: val = strJoin(adgroups.Item("kw").Item("values").Item(adgroup), newLine()) ZeileIdx = ZeileAds.Item("kw").Item("start")(sheetIdx) .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val .VerticalAlignment = xlTop ' .VerticalAlignment = xlDistributed ' .VerticalAlignment = xlJustify End With '' SITELINKS: ZeileIdx = ZeileAds.Item("sitelink").Item("start")(sheetIdx) For Each dummy In adgroups.Item("sitelink").Item("adgroup").Item("values").Item(adgroup) Call generateSitelink(ZeileIdx, SpalteIdx, Sheets(sheetname), CInt(dummy), blatt_sitelink, sitelinkAttrib, RGB_alert) Next '' CALLOUTS: ZeileIdx = ZeileAds.Item("callout").Item("start")(sheetIdx) For Each dummy In adgroups.Item("callout").Item("adgroup").Item("values").Item(adgroup) Call generateCallout(ZeileIdx, SpalteIdx, Sheets(sheetname), CInt(dummy), blatt_callout, calloutAttrib, RGB_alert) Next '' SNIPPETS: ZeileIdx = ZeileAds.Item("snippet").Item("start")(sheetIdx) For Each dummy In adgroups.Item("snippet").Item("adgroup").Item("values").Item(adgroup) Call generateSnippet(ZeileIdx, SpalteIdx, Sheets(sheetname), CInt(dummy), blatt_snippet, snippetAttrib, RGB_alert, snippets_sepchar, snippets_joinchar) Next ' '' Spalten verbergen: (funktioniert nicht) ' .Columns(SpalteIdx+2).EntireColumn.Hidden = True ' .Columns(SpalteIdx+3).EntireColumn.Hidden = True SpalteIdx = SpalteIdx + SpaltenbreiteAdgroup Next key_adgroup '' CAMPAGNEEBENE-ERWEITERUNG SpalteIdx = 2 '' SITELINKS: ZeileIdx = ZeileAds.Item("sitelink_c").Item("start")(sheetIdx) For Each dummy In adgroups.Item("sitelink").Item("c") Call generateSitelink(ZeileIdx, SpalteIdx, Sheets(sheetname), CInt(dummy), blatt_sitelink, sitelinkAttrib, RGB_alert) Next '' CALLOUTS: ZeileIdx = ZeileAds.Item("callout_c").Item("start")(sheetIdx) For Each dummy In adgroups.Item("callout").Item("c") Call generateCallout(ZeileIdx, SpalteIdx, Sheets(sheetname), CInt(dummy), blatt_callout, calloutAttrib, RGB_alert) Next '' SNIPPETS: ZeileIdx = ZeileAds.Item("snippet_c").Item("start")(sheetIdx) For Each dummy In adgroups.Item("snippet").Item("c") Call generateSnippet(ZeileIdx, SpalteIdx, Sheets(sheetname), CInt(dummy), blatt_snippet, snippetAttrib, RGB_alert, snippets_sepchar, snippets_joinchar) Next End With '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '' In Index Fortschritt/Statistiken protokollieren: '''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With Sheets(blatt_namespace.Item("name")) i = namespaceAttrib.Item("map").Item("values").Item(key_c).Item("row") '' STATISTIKEN EINTRAGEN If anzahl_adgroups > 0 Then .Cells(i, blatt_namespace.Item("spalte").Item("adgroup")).value = anzahl_adgroups .Cells(i, blatt_namespace.Item("spalte").Item("ads")).value = anzahl_ads / anzahl_adgroups .Cells(i, blatt_namespace.Item("spalte").Item("kw")).value = anzahl_kw / anzahl_adgroups End If '' MARKIERE FORTSCHRITT .Cells(i, blatt_namespace.Item("spalte").Item("progress")).Interior.Color = RGB(0, 0, 0) If bool_c Then '' Im Index/Namespace die Kampagne markieren, falls mind. 1 Ad einen Fehler enthält .UsedRange.Rows(i).Interior.Color = RGB_alert End If End With End If Next key_c i = 1 Do While i <= sheetlist.Count With Sheets(sheetlist(i)) '' RAHMEN ENTFERNEN u. FONT SETZEN With .Cells With .Font .Name = "Calibri" .TintAndShade = 0 End With .Columns.AutoFit With .Borders .LineStyle = xlNone .Color = RGB(255, 255, 255) End With End With '' AUßER VOR & NACH ADS: With .Rows(ZeileAds.Item("ads").Item("start")(i)).EntireRow.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .Color = RGB(0, 0, 0) End With With .Rows(ZeileAds.Item("ads").Item("end")(i)).EntireRow.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .Color = RGB(0, 0, 0) End With With .Columns(1) .Font.Bold = True .Cells(2, 1).value = "Campaign" .Cells(3, 1).value = "Ad Group" .Cells(ZeileAds.Item("ads").Item("start")(i) - 1, 1).value = "Ads" .Cells(ZeileAds.Item("ads").Item("end")(i), 1).value = "Final URL" .Cells(ZeileAds.Item("kw").Item("start")(i)-1, 1).value = "ADGRUPPE" .Cells(ZeileAds.Item("sitelink").Item("start")(i), 1).value = "Sitelinks" .Cells(ZeileAds.Item("callout").Item("start")(i), 1).value = "Callouts" .Cells(ZeileAds.Item("snippet").Item("start")(i), 1).value = "Snippets" .Cells(ZeileAds.Item("sitelink_c").Item("start")(i)-1, 1).value = "KAMPAGNE" .Cells(ZeileAds.Item("sitelink_c").Item("start")(i), 1).value = "Sitelinks" .Cells(ZeileAds.Item("callout_c").Item("start")(i), 1).value = "Callouts" .Cells(ZeileAds.Item("snippet_c").Item("start")(i), 1).value = "Snippets" With .Cells(ZeileAds.Item("kw").Item("start")(i), 1) .value = "Keywords" .VerticalAlignment = xlTop ' .VerticalAlignment = xlDistributed ' .VerticalAlignment = xlJustify End With End With End With i = i + 1 Loop Sheets(blatt_namespace.Item("name")).Select Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox ("HINWEIS: Die Datei muss evtl. geschlossen und wieder geöffnet werden, damit die bedingte Formattierung (bzgl. Textlängen) funktioniert.") End Sub '' SONSTIGE FUNKTIONEN FÜR HAUPTVORGANG Private Function removeOldReports(del As Collection) As Boolean Dim key As Variant Dim sheetname As String Dim confirmtext As String Dim msgresult As VbMsgBoxResult removeOldReports = True If del.Count > 0 Then confirmtext = "" For Each key In del sheetname = CStr(key) If Len(confirmtext) > 0 Then confirmtext = confirmtext & newLine() & "[" & sheetname & "]" Else confirmtext = "[" & sheetname & "]" End If Next key msgresult = MsgBox(confirmtext, vbYesNoCancel, "Löschung von (den alten) Berichten bitte bestätigen!") If msgresult = VbMsgBoxResult.vbCancel Then removeOldReports = False Exit Function ElseIf msgresult = VbMsgBoxResult.vbNo Then Exit Function ElseIf msgresult = VbMsgBoxResult.vbYes Then For Each key In del sheetname = CStr(key) If existiertBlatt(sheetname) Then Application.DisplayAlerts = False Sheets(sheetname).Delete Application.DisplayAlerts = True End If Next key End If End If End Function Private Function existiertBlatt(blatt_nom As String, Optional echo As Boolean = False) As Boolean Dim bool As Boolean bool = False For Each Sheet In Worksheets If Sheet.Name = blatt_nom Then bool = True Exit For End If Next Sheet If echo And Not bool Then: MsgBox ("Blatt [" & blatt_nom & "] existiert nicht!") existiertBlatt = bool End Function Private Sub createBlatt(blatt_nom As String, Optional after As Boolean = True, Optional idx As Integer = 1) Dim ws As Worksheet Set ws = ActiveWorkbook.Sheets.Add() ws.Move Before:=Sheets(1) If after Then ws.Move after:=Sheets(idx + 1) Else ws.Move Before:=Sheets(idx + 1) End If ws.Name = blatt_nom End Sub Private Function existierenSpaltenInBlatt(blatt As Collection, attrib As Collection, Optional iHead As Integer = 1) As Boolean Dim bool As Boolean Dim blatt_nom As String Dim spalte As String blatt_nom = blatt.Item("name") bool = True For Each key In attrib.Item("keys") Dim j As Integer spalte = attrib.Item("name").Item(key) If Not getColumnIndex(blatt_nom, spalte, j, iHead) Then bool = False MsgBox ("Spalte [" & spalte & "] fehlt in Blatt [" & blatt_nom & "]!") Exit For End If blatt.Item("spalte").Add key:=key, Item:=j Next key existierenSpaltenInBlatt = bool End Function Private Function getColumnIndex(blatt_nom As String, colHead As String, idx As Integer, Optional iHead As Integer = 1) As Boolean Dim ws As Worksheet Dim gefunden As Boolean Dim lastCol As Integer Dim j As Integer Dim head As String Set ws = Sheets(blatt_nom) gefunden = False idx = -1 lastCol = ws.UsedRange.Columns.Count j = 1 Do While j <= lastCol head = ws.Cells(iHead, j).value If head = colHead Then idx = j gefunden = True Exit Do End If j = j + 1 Loop getColumnIndex = gefunden End Function Private Function checkSheet(blatt As Collection, stAttrib As Collection, specAttrib As Collection) As Boolean Dim sheetname As String Dim j_c As Integer Dim j_adgroup As Integer checkSheet = False '' PRÜFE, OB SHEETS UND SPALTEN EXISTIEREN. If Not existiertBlatt(blatt.Item("name"), True) Then: Exit Function If Not existierenSpaltenInBlatt(blatt, stAttrib, 1) Then: Exit Function If Not existierenSpaltenInBlatt(blatt, specAttrib, 1) Then: Exit Function '' SORTIERE INPUT-DATEN NACH c DANN adgroup: sheetname = blatt.Item("name") j_c = blatt.Item("spalte").Item("c") j_adgroup = blatt.Item("spalte").Item("adgroup") With Sheets(sheetname).Cells .Sort key1:=.Columns(j_c), order1:=xlAscending, key2:=.Columns(j_adgroup), order2:=xlAscending, Header:=xlYes End With checkSheet = True End Function Private Sub setupNamespace(blatt As Collection, attrib As Collection, src_blaetter As Collection, key_from As String, key_um As String, key_sheet As String, key_show As String, key_delete As String) Dim j_src As Integer Dim j_from As Integer Dim j_um As Integer Dim j_sheet As Integer Dim j_show As Integer Dim j_delete As Integer Dim i As Integer Dim i_from As Integer Dim lastRow As Integer Dim s As Integer Dim nom As String Dim nom_src As String Dim x As String Dim y As String Dim sheetname As String Call setupKeyValue(attrib.Item("map")) nom = blatt.Item("name") j_from = blatt.Item("spalte").Item(key_from) j_um = blatt.Item("spalte").Item(key_um) j_sheet = blatt.Item("spalte").Item(key_sheet) j_show = blatt.Item("spalte").Item(key_show) j_delete = blatt.Item("spalte").Item(key_delete) With Sheets(nom) .Select With ActiveWindow .FreezePanes = False .SplitColumn = 1 .SplitRow = 1 .FreezePanes = True End With .Cells(1, j_from).AddComment "Kampagnennamen" .Cells(1, j_um).AddComment "Erwünschter Blattname." .Cells(1, j_sheet).AddComment "Blattnamen: max. 31-Zeichen. Der #-Tag stellt die Eindeutigkeit von Namen sicher." .Cells(1, j_show).AddComment "WAHR: Blatt überschreiben; FALSCH/LEER: Stand beibehalten." .Cells(1, j_delete).AddComment "WAHR: Blatt löschen; FALSCH/LEER: Blatt beibehalten." j = blatt.Item("spalte").Item("adgroup") .Cells(1, j).AddComment "Anzahl von Adgruppen in der Kampagne" .Columns(j).NumberFormat = "0" j = blatt.Item("spalte").Item("ads") .Cells(1, j).AddComment "Durchschnittliche Anzahl von Ads pro Adgruppe" .Columns(j).NumberFormat = "0.00" j = blatt.Item("spalte").Item("kw") .Cells(1, j).AddComment "Durchschnittliche Anzahl von Keywords pro Adgruppe" .Columns(j).NumberFormat = "0.00" j = blatt.Item("spalte").Item("progress") .Cells(1, j).AddComment "Zur visuellen Mitteilung des Fortschritts des Skripts" For Each blatt_src In src_blaetter nom_src = blatt_src.Item("name") j_src = blatt_src.Item("spalte").Item(key_from) i = .UsedRange.Rows.Count + 1 lastRow = Sheets(nom_src).UsedRange.Rows.Count i_from = 2 Do While i_from <= lastRow x = Sheets(nom_src).Cells(i_from, j_src).text If Len(x) > 0 And Not hasValue(attrib.Item("map").Item("keys"), x) Then y = campaignnamenUmbenennung(x) .Cells(i, j_from) = x .Cells(i, j_um) = y .Cells(i, j_show) = True .Cells(i, j_delete) = "" attrib.Item("map").Item("keys").Add x i = i + 1 End If i_from = i_from + 1 Loop Next blatt_src With .UsedRange .Interior.Color = xlNone .Columns.AutoFit .Sort key1:=.Columns(j_um), order1:=xlAscending, Header:=xlYes .Columns(j_um).Interior.Color = RGB(0, 153, 255) .Columns(j_show).Interior.Color = RGB(0, 153, 255) .Columns(j_delete).Interior.Color = RGB(0, 153, 255) End With lastRow = .UsedRange.Rows.Count i = 2 s = 0 Do While i <= lastRow x = .Cells(i, j_from).text y = campaignnamenUmbenennung(x) sheetname = "#" + CStr(s) If Len(sheetname) < MAXSHEETNAMELENGTH() Then: sheetname = Left(y, MAXSHEETNAMELENGTH() - Len(sheetname)) & sheetname '' Künftige Aufgabe: Hyperlinks in Index erstellen. .Cells(i, j_from).Formula = "=HYPERLINK(""#'" & sheetname & "'!A1"", """ & x & """)" .Cells(i, j_sheet) = sheetname With attrib.Item("map").Item("values") .Add key:=x, Item:=New Collection With .Item(x) .Add key:="row", Item:=i .Add key:=key_um, Item:=y .Add key:=key_sheet, Item:=sheetname End With End With i = i + 1 s = s + 1 Loop With .UsedRange .Columns.AutoFit With .Font .Name = "Calibri" .Size = 10 End With With .Columns(j_sheet) .EntireColumn.Hidden = True With .Font .Name = "Courier New" .Size = 8 End With End With With .Rows(1) With .Font .Name = "Calibri" .Size = 10 End With .Interior.Color = RGB(191, 191, 191) End With End With End With End Sub Private Sub mapNamespace(blatt As Collection, attrib As Collection, key_from As String, key_um As String, key_sheet As String, key_show As String, key_delete As String) Dim j_from As Integer Dim j_um As Integer Dim j_sheet As Integer Dim j_show As Integer Dim j_delete As Integer Dim i As Integer Dim lastRow As Integer Dim s As Integer Dim nom As String Dim x As String Dim y As String Dim show As Boolean Dim del As Boolean Dim sheetname As String Dim update As Boolean nom = blatt.Item("name") j_from = blatt.Item("spalte").Item(key_from) j_um = blatt.Item("spalte").Item(key_um) j_sheet = blatt.Item("spalte").Item(key_sheet) j_show = blatt.Item("spalte").Item(key_show) j_delete = blatt.Item("spalte").Item(key_delete) lastRow = Sheets(nom).UsedRange.Rows.Count i = 2 s = 0 Call setupKeyValue(attrib.Item("map")) With Sheets(nom) Do While i <= lastRow x = Sheets(nom).Cells(i, j_from).text show = checkIfTrue(Sheets(nom).Cells(i, j_show).text, False) del = checkIfTrue(Sheets(nom).Cells(i, j_delete).text, False) update = True If Len(x) > 0 And Not hasValue(attrib.Item("map").Item("keys"), x) Then y = Sheets(nom).Cells(i, j_um) If Len(y) = 0 Then: y = x sheetname = Sheets(nom).Cells(i, j_sheet) If del Then attrib.Item("delete").Add sheetname ElseIf show Then With attrib.Item("map") .Item("keys").Add x .Item("values").Add key:=x, Item:=New Collection With .Item("values").Item(x) .Add key:="row", Item:=i .Add key:=key_um, Item:=y .Add key:=key_sheet, Item:=sheetname End With End With Else update = False End If End If If update Then .Rows(i).Interior.Color = xlNone .Cells(i, j_um).Interior.Color = RGB(0, 153, 255) .Cells(i, j_show).Interior.Color = RGB(0, 153, 255) .Cells(i, j_delete).Interior.Color = RGB(0, 153, 255) .Cells(i, blatt.Item("spalte").Item("adgroup")).ClearContents .Cells(i, blatt.Item("spalte").Item("ads")).ClearContents .Cells(i, blatt.Item("spalte").Item("kw")).ClearContents End If If del Then .Cells(i, blatt.Item("spalte").Item("progress")).Interior.Color = RGB(0, 0, 0) End If s = s + 1 i = i + 1 Loop End With End Sub Private Function createNamespace(blatt As Collection, attrib As Collection, Optional iHead As Integer = 1) As Boolean Dim bool As Boolean Dim sheetname As String sheetname = blatt.Item("name") If existiertBlatt(sheetname) Then createNamespace = existierenSpaltenInBlatt(blatt, attrib, iHead) Else Call createBlatt(sheetname, False, 1) Dim j As Integer j = 1 For Each key In attrib.Item("keys") With Sheets(sheetname).Cells(1, j) .value = attrib.Item("name").Item(key) .Font.Bold = True End With blatt.Item("spalte").Add key:=key, Item:=j j = j + 1 Next key createNamespace = True End If End Function Private Function getAdgroupData(campaignName As String, blatt_ads As Collection, blatt_kw As Collection, blatt_sitelink As Collection, blatt_callout As Collection, blatt_snippet As Collection) As Collection ' Dim adgroups As New objkeyArray ' Dim key As String ' For Each key In Array("ads","kw","sitelink","callout","snippet") ' Call adgroups.push(New objkeyArray, key) ' Call adgroups.value(key).push(New objkeyArray, "data") ' Call adgroups.value(key).push(New objkeyArray, "stats") ' Next Dim adgroups As New Collection Dim ws As Worksheet Dim lastRow As Long Dim j_c As Integer Dim j_adgroup As Integer Dim j_kw As Integer Dim j_feed As Integer Dim feed As String Dim i As Long Dim nMax As Integer Dim nMax_c As Integer Dim campaign As String Dim adgroup As String Dim bool_leer As Boolean Dim key As Variant Dim val As Variant With adgroups For Each key In Array("ads","kw") .Add key:=CStr(key), Item:=New Collection Call setupKeyValue(.Item(key)) Next For Each key In Array("sitelink","callout","snippet") .Add key:=CStr(key), Item:=New Collection With .Item(key) .Add key:="adgroup", Item:=New Collection .Add key:="c", Item:=New Collection Call setupKeyValue(.Item("adgroup")) End With Next End With bool_leer = False '' SAMMLE ZEILENNR VON ADS With blatt_ads Set ws = Sheets(.Item("name")) lastRow = ws.UsedRange.Rows.Count With .Item("spalte") j_c = .Item("c") j_adgroup = .Item("adgroup") End With End With nMax = 0 i = 2 Do While i <= lastRow campaign = ws.Cells(i, j_c).value adgroup = ws.Cells(i, j_adgroup).value If campaign = campaignName Then If adgroup = "" Then Else ' For Each key in adgroups.keys ' If Not adgroups.value(key).value("data").hasKey(adgroup) Then: adgroups.value(key).value("data").push(New strArray, adgroup) ' Next ' With adgroups.value("ads").value("data").value(adgroup) ' Call(.push(i)) ' If .Length > nMax Then: nMax = .length ' End With Call addValueIfKeyMissing(adgroups.Item("ads"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("kw"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("sitelink").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("callout").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("snippet").Item("adgroup"), adgroup, New Collection) With adgroups.Item("ads").Item("values").Item(adgroup) .Add i If .Count > nMax Then: nMax = .Count End With End If End If i = i + 1 Loop ' Call adgroups.value("ads").value("stats").push(nMax,"max") adgroups.Add key:="maxcount_ads", Item:=nMax '' SAMMLE KEYWORDLISTE FÜR JEDE ADGRUPPE With blatt_kw Set ws = Sheets(.Item("name")) lastRow = ws.UsedRange.Rows.Count With .Item("spalte") j_c = .Item("c") j_adgroup = .Item("adgroup") j_kw = .Item("kw") End With End With nMax = 0 i = 2 Do While i <= lastRow campaign = ws.Cells(i, j_c).value adgroup = ws.Cells(i, j_adgroup).value If campaign = campaignName Then If adgroup = "" Then Else ' For Each key in adgroups.keys ' If Not adgroups.value(key).value("data").hasKey(adgroup) Then: adgroups.value(key).value("data").push(New strArray, adgroup) ' Next ' With adgroups.value("kw").value("data").value(adgroup) ' Call(.push(ws.Cells(i, j_kw).value)) ' If .Length > nMax Then: nMax = .length ' End With Call addValueIfKeyMissing(adgroups.Item("ads"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("kw"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("sitelink").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("callout").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("snippet").Item("adgroup"), adgroup, New Collection) With adgroups.Item("kw").Item("values").Item(adgroup) .Add ws.Cells(i, j_kw).value If .Count > nMax Then: nMax = .Count End With End If End If i = i + 1 Loop ' Call adgroups.value("kw").value("stats").push(nMax,"max") adgroups.Add key:="maxcount_kw", Item:=nMax '' SAMMLE SITELINKS With blatt_sitelink Set ws = Sheets(blatt_sitelink.Item("name")) lastRow = ws.UsedRange.Rows.Count With .Item("spalte") j_c = .Item("c") j_adgroup = .Item("adgroup") j_feed = .Item("feed") End With End With nMax = 0 nMax_c = 0 i = 2 Do While i <= lastRow campaign = ws.Cells(i, j_c).value adgroup = ws.Cells(i, j_adgroup).value feed = ws.Cells(i, j_feed).value If campaign = campaignName And feed Like "*Sitelink*" Then If adgroup = "" Then adgroups.Item("sitelink").Item("c").Add i nMax_c = nMax_c + 1 Else ' For Each key in adgroups.keys ' If Not adgroups.value(key).value("data").hasKey(adgroup) Then: adgroups.value(key).value("data").push(New strArray, adgroup) ' Next ' With adgroups.value("sitelink").value("data").value(adgroup) ' Call(.push(i)) ' If .Length > nMax Then: nMax = .length ' End With Call addValueIfKeyMissing(adgroups.Item("ads"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("kw"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("sitelink").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("callout").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("snippet").Item("adgroup"), adgroup, New Collection) With adgroups.Item("sitelink").Item("adgroup").Item("values").Item(adgroup) .Add i If .Count > nMax Then: nMax = .Count End With End If End If i = i + 1 Loop ' Call adgroups.value("sitelink").value("stats").push(nMax,"max") adgroups.Add key:="maxcount_sitelink", Item:=nMax adgroups.Add key:="maxcount_sitelink_c", Item:=nMax_c '' SAMMLE CALLOUTS With blatt_callout Set ws = Sheets(blatt_callout.Item("name")) lastRow = ws.UsedRange.Rows.Count With .Item("spalte") j_c = .Item("c") j_adgroup = .Item("adgroup") j_feed = .Item("feed") End With End With nMax = 0 nMax_c = 0 i = 2 Do While i <= lastRow campaign = ws.Cells(i, j_c).value adgroup = ws.Cells(i, j_adgroup).value feed = ws.Cells(i, j_feed).value If campaign = campaignName And feed Like "*Zusatzinformationen*" Then If adgroup = "" Then adgroups.Item("callout").Item("c").Add i nMax_c = nMax_c + 1 Else ' For Each key in adgroups.keys ' If Not adgroups.value(key).value("data").hasKey(adgroup) Then: adgroups.value(key).value("data").push(New strArray, adgroup) ' Next ' With adgroups.value("callout").value("data").value(adgroup) ' Call(.push(i)) ' If .Length > nMax Then: nMax = .length ' End With Call addValueIfKeyMissing(adgroups.Item("ads"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("kw"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("sitelink").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("callout").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("snippet").Item("adgroup"), adgroup, New Collection) With adgroups.Item("callout").Item("adgroup").Item("values").Item(adgroup) .Add i If .Count > nMax Then: nMax = .Count End With End If End If i = i + 1 Loop ' Call adgroups.value("callout").value("stats").push(nMax,"max") adgroups.Add key:="maxcount_callout", Item:=nMax adgroups.Add key:="maxcount_callout_c", Item:=nMax_c '' SAMMLE SNIPPETS With blatt_callout Set ws = Sheets(blatt_snippet.Item("name")) lastRow = ws.UsedRange.Rows.Count With .Item("spalte") j_c = .Item("c") j_adgroup = .Item("adgroup") j_feed = .Item("feed") End With End With nMax = 0 nMax_c = 0 i = 2 Do While i <= lastRow campaign = ws.Cells(i, j_c).value adgroup = ws.Cells(i, j_adgroup).value feed = ws.Cells(i, j_feed).value If campaign = campaignName And feed Like "*Snippet*" Then If adgroup = "" Then adgroups.Item("snippet").Item("c").Add i nMax_c = nMax_c + 1 Else ' For Each key in adgroups.keys ' If Not adgroups.value(key).value("data").hasKey(adgroup) Then: adgroups.value(key).value("data").push(New strArray, adgroup) ' Next ' With adgroups.value("snippet").value("data").value(adgroup) ' Call(.push(i)) ' If .Length > nMax Then: nMax = .length ' End With Call addValueIfKeyMissing(adgroups.Item("ads"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("kw"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("sitelink").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("callout").Item("adgroup"), adgroup, New Collection) Call addValueIfKeyMissing(adgroups.Item("snippet").Item("adgroup"), adgroup, New Collection) With adgroups.Item("snippet").Item("adgroup").Item("values").Item(adgroup) .Add i If .Count > nMax Then: nMax = .Count End With End If End If i = i + 1 Loop ' Call adgroups.value("snippet").value("stats").push(nMax,"max") adgroups.Add key:="maxcount_snippet", Item:=nMax adgroups.Add key:="maxcount_snippet_c", Item:=nMax_c Set getAdgroupData = adgroups End Function Private Sub generateSitelink(ByRef ZeileIdx As Integer, ByRef SpalteIdx As Integer, ws As Worksheet, i As Integer, blatt_sitelink As Collection, sitelinkAttrib As Collection, RGB As Long) Dim key As String Dim maxlen As Integer Dim addr As String Dim sformula As String Dim val As Variant Dim j As Integer With ws key = "text" With blatt_sitelink j = .Item("spalte").Item(key) val = Sheets(.Item("name")).Cells(i, j).value End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Size = 10 .Bold = True End With maxlen = sitelinkAttrib.Item("maxlength").Item(key) addr = .Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr & " > " & maxlen & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB .StopIfTrue = False End With End With '' Counts Sitelink-text With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=LEN(" & addr & ")" End With ZeileIdx = ZeileIdx + 1 key = "line1" With blatt_sitelink j = .Item("spalte").Item(key) val = Sheets(.Item("name")).Cells(i, j).value End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Size = 10 End With maxlen = sitelinkAttrib.Item("maxlength").Item(key) addr = .Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr & " > " & maxlen & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB .StopIfTrue = False End With End With '' Counts Sitelink: Description Line 1 With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=LEN(" & addr & ")" End With ZeileIdx = ZeileIdx + 1 key = "line2" With blatt_sitelink j = .Item("spalte").Item(key) val = Sheets(.Item("name")).Cells(i, j).value End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Size = 10 End With maxlen = sitelinkAttrib.Item("maxlength").Item(key) addr = .Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr & " > " & maxlen & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB .StopIfTrue = False End With End With '' Counts Sitelink: Description Line 2 With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=LEN(" & addr & ")" End With ZeileIdx = ZeileIdx + 1 key = "finalurl" With blatt_sitelink j = .Item("spalte").Item(key) val = Sheets(.Item("name")).Cells(i, j).value End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Size = 10 .ThemeColor = xlThemeColorAccent6 .ThemeFont = xlThemeFontMinor .Underline = xlUnderlineStyleNone End With End With ZeileIdx = ZeileIdx + 2 End With End Sub Private Sub generateCallout(ByRef ZeileIdx As Integer, ByRef SpalteIdx As Integer, ws As Worksheet, i As Integer, blatt_callout As Collection, calloutAttrib As Collection, RGB As Long) Dim key As String Dim maxlen As Integer Dim addr As String Dim sformula As String Dim val As Variant Dim j As Integer With ws key = "text" With blatt_callout j = .Item("spalte").Item(key) val = Sheets(.Item("name")).Cells(i, j).value End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val With .Font .Size = 10 End With maxlen = calloutAttrib.Item("maxlength").Item(key) addr = .Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr & " > " & maxlen & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB .StopIfTrue = False End With End With '' Counts Callout-text With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=LEN(" & addr & ")" End With ZeileIdx = ZeileIdx + 1 End With End Sub Private Sub generateSnippet(ByRef ZeileIdx As Integer, ByRef SpalteIdx As Integer, ws As Worksheet, i As Integer, blatt_snippet As Collection, snippetAttrib As Collection, RGB As Long, snippets_sepchar As Collection, snippets_joinchar As String) Dim key As String Dim maxlen As Integer Dim addr As String Dim sformula As String Dim val As Variant Dim val1 As Variant Dim snips As Collection Dim j As Integer With ws key = "head" With blatt_snippet j = .Item("spalte").Item(key) val = Sheets(.Item("name")).Cells(i, j).value End With key = "snippet" With blatt_snippet j = .Item("spalte").Item(key) val1 = Sheets(.Item("name")).Cells(i, j).value Set snips = strSplit(CStr(val1), snippets_sepchar) val1 = strJoin(snips, snippets_joinchar & " ", True) If snips.Count > 0 Then: val1 = " " & val1 & snippets_joinchar End With .Range(.Cells(ZeileIdx, SpalteIdx), .Cells(ZeileIdx, SpalteIdx + 1)).Merge With .Cells(ZeileIdx, SpalteIdx) .value = val & ":" & val1 With .Font .Size = 10 End With maxlen = snippetAttrib.Item("maxlength").Item(key) addr = .Offset(0, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False) sformula = "=(" & addr & " > " & maxlen & ")" addr = .Address(RowAbsolute:=False, ColumnAbsolute:=False) With .FormatConditions.Add(Type:=xlExpression, Formula1:=sformula) .Interior.Color = RGB .StopIfTrue = False End With End With '' Counts Snippets: Wert enhält der durschnittslänge der Snippets With .Cells(ZeileIdx, SpalteIdx + 2) .Formula = "=getmaxsnippetlength(" & addr & ", """ & snippets_joinchar & """)" '.NumberFormat = "0.0" End With ZeileIdx = ZeileIdx + 1 End With End Sub '' MISC. FUNKTIONEN Private Function hasKey_vb(coll As Collection, key As String) As Boolean Dim var As Variant Dim errNumber As Long Set var = Nothing hasKey_vb = False Err.Clear On Error Resume Next var = coll.Item(key) errNumber = CLng(Err.Number) On Error GoTo 0 'Fehlercode ist 5, falls "nicht in" und 0 od. 438, falls "in". hasKey_vb = True If errNumber = 5 Then: hasKey_vb = False End Function Private Sub setupKeyValue(coll As Collection) If Not hasKey_vb(coll, "keys") Then: coll.Add key:="keys", Item:=New Collection If Not hasKey_vb(coll, "values") Then: coll.Add key:="values", Item:=New Collection End Sub Private Sub pushKeyValue(coll As Collection, key As String, value) coll.Item("keys").Add key coll.Item("values").Add key:=key, Item:=value End Sub Private Function hasKey(coll As Collection, key As String) As Boolean hasKey = hasValue(coll.Item("keys"), key) End Function Private Function hasValue(coll As Collection, val As String) As Boolean hasValue = False Dim val_in As Variant For Each val_in In coll If CStr(val_in) = val Then hasValue = True Exit For End If Next val_in End Function Private Sub addValueIfKeyMissing(coll As Collection, key As String, value) If Not hasKey(coll, key) Then: Call pushKeyValue(coll, key, value) End Sub Private Function checkIfTrue(x As String, Optional def As Boolean = False) As Boolean checkIfTrue = def If def Then If x = "FALSCH" Or x = "FALSE" Or x = "0" Or x = "Nein" Or x = "nein" Or x = "No" Or x = "no" Then: checkIfTrue = False Else If x = "WAHR" Or x = "TRUE" Or x = "1" Or x = "Ja" Or x = "ja" Or x = "Yes" Or x = "yes" Then: checkIfTrue = True End If End Function Private Function newLine() As String ' newLine = vbNewLine #If Mac Then newLine = Chr(13) #Else newLine = Chr(10) #End If End Function Private Function strJoin(coll As Collection, sep As String, Optional skipblank As Boolean = True) As String Dim str As String Dim val As Variant Dim text As String Dim firsttime As Boolean firsttime = True str = "" For Each val In coll text = CStr(val) If Not skipblank Or Len(text) > 0 Then If firsttime Then str = text firsttime = False Else str = str & sep & text End If End If Next val strJoin = str End Function Private Function strSplit(str As String, sep As Collection) As Collection Dim coll As New Collection Dim u As Variant Dim u0 As String Dim w As String Dim laenge As Integer Dim laenge0 As Integer Dim found As Boolean Do While Len(str) > 0 laenge0 = Len(str) + 1 found = False For Each u In sep laenge = strIndexOf(str, CStr(u)) If laenge > 0 Then found = True If laenge < laenge0 Then laenge0 = laenge u0 = u End If End If Next If Not found Or laenge0 = 0 Then coll.Add str str = "" Else w = strSplice(str, 1, laenge0 + Len(u0) - 1) w = Left(w, laenge0 - 1) coll.Add w End If Loop Set strSplit = coll End Function Private Function strSplice(ByRef str As String, i1 As Integer, Optional len1 As Integer = -1) As String Dim L As Integer Dim i2 As Integer Dim len2 As Integer Dim j2 As Integer L = Len(str) If i1 <= 0 Then i1 = 1 End If If i1 > L Then strSplice = "" str = "" Exit Function End If If len1 = -1 Or (i1 + len1 - 1) > L Then len1 = L - i1 + 1 End If i2 = i1 + len1 len2 = L - i2 + 1 strSplice = Mid(str, i1, len1) str = Mid(str, i2, len2) End Function Private Function strIndexOf(str As String, u As String, Optional startIdx As Integer = 1) As Integer Dim L1 As Integer Dim L2 As Integer Dim i As Integer Dim v As String strIndexOf = 0 L1 = Len(str) L2 = Len(u) If startIdx < 1 Then startIdx = 1 End If i = startIdx Do While i <= (L1 - L2 + 1) v = Mid(str, i, L2) If u = v Then strIndexOf = i Exit Do End If i = i + 1 Loop End Function Function getmaxsnippetlength(cell As Range, sep As String) As Integer Dim text As String Dim snippetstext As String Dim iSnip As Integer Dim L As Integer Dim Lmax As Integer Dim sepColl As New Collection sepColl.Add sep text = cell.value iSnip = strIndexOf(text, ":") + 1 snippetstext = strSplice(text, iSnip) Lmax = 0 For Each snippet In strSplit(snippetstext, sepColl) L = Len(Trim(snippet)) If L > Lmax Then: Lmax = L Next getmaxsnippetlength = Lmax End Function ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' '''' KLASSEN ''''''''''''''''''''''''''''''''''''''''''''''''''' ' (getrennt als objkeyArray.cls und strArray.cls zu verwenden)