Benutzer:Schreibkraft/Excel-Meta-Auflagen-Zeitungen-DE.vba

aus Wikipedia, der freien Enzyklopädie
Zur Navigation springen Zur Suche springen

Hier nachstehend ist der Code für EXCEL-Umwandlung von IVW-Auflagendaten für Tageszeitungen für die PC-Version EXCEL-2003.

Hinweise zur Einbindung des Codes in eine Excel-Datei finden sich hier. 

Option Explicit
Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Löscht überflüssige Einträge und ersetzt Abkürzungen bei Tageszeitungen
'Automatisiert die Aktualisierung der Daten in den Wikipedia-Vorlagen
Dim Zahl As Integer
Dim LastRow As Integer
Dim NewLastRow As Integer
Dim Zielzahl As Integer
Dim Quartal, Vorquartal As Integer
Dim Jahr, Vorquartaljahr As Integer
Dim Quartalstext As String
Dim FT, FTAbo, NOZ, NOZAbo, Bild, BildAbo, BZ, BZAbo, BildBZWest, BildBZWestAbo, BildBZOst, BildBZOstAbo As Long
Dim byWert As Integer
Dim WS As Worksheet


If CheckSheet("Wikipedia-Daten") = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Wikipedia-Daten"
End If

If CheckSheet("IVW-Detail") = False Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "IVW-Detail"
End If

LastRow = Range("A" & Rows.Count).End(xlUp).Row

'Löscht alte Tabelle
Worksheets("Wikipedia-Daten").Range("A1:Z10000").EntireRow.Clear

'Ermittelt Quartal
Quartal = Mid(Range("A2"), 5, 1)
'Ermittelt Jahr
Jahr = Mid(Range("A2"), 1, 4)

If Quartal = 1 Then
  Quartalstext = "erstes Quartal"
  Vorquartal = 4
  Vorquartaljahr = Jahr - 1
  ElseIf Quartal = 2 Then
  Quartalstext = "zweites Quartal"
  Vorquartal = 1
  Vorquartaljahr = Jahr
  ElseIf Quartal = 3 Then
  Quartalstext = "drittes Quartal"
  Vorquartal = 2
  Vorquartaljahr = Jahr
    ElseIf Quartal = 4 Then
  Quartalstext = "viertes Quartal"
  Vorquartal = 3
  Vorquartaljahr = Jahr
   End If
   
   'Schreibt Vorspann
Worksheets("Wikipedia-Daten").Range("A1").Value = "{{#switch: {{{1}}}"
Worksheets("Wikipedia-Daten").Range("A2").Value = "| Quartalstext = {{#switch: {{{2}}}"
Worksheets("Wikipedia-Daten").Range("A3").Value = "| Liste und Infobox = [[Informationsgemeinschaft zur Feststellung der Verbreitung von Werbeträgern|IVW]] " & Quartal & "/" & Jahr
Worksheets("Wikipedia-Daten").Range("A4").Value = "| Artikel           = laut [[Informationsgemeinschaft zur Feststellung der Verbreitung von Werbeträgern|IVW]], " & Quartalstext & " " & Jahr
Worksheets("Wikipedia-Daten").Range("A5").Value = "| IVW-Kürzel        = " & Range("A2") & "}}"

'Löscht alle Auflagen zu E-Paper und Samstagausgaben
For Zahl = 1 To LastRow Step 1
If Range("E" & Zahl).Formula = "davon ePaper" Or Range("H" & Zahl).Formula = "Sa" Then
Rows(Zahl).Clear
End If
Next Zahl



'Berechnet Gesamtauflage Fränkischer Tag
FT = 0
FTAbo = 0
For Zahl = 1 To LastRow Step 1
If Range("C" & Zahl).Formula = "1770" Or Range("C" & Zahl).Formula = "1477" Or Range("C" & Zahl).Formula = "1529" Or Range("C" & Zahl).Formula = "1580" Or Range("C" & Zahl).Formula = "1521" Or Range("C" & Zahl).Formula = "1561" Then
FT = FT + Range("L" & Zahl).Value
FTAbo = FTAbo + Range("O" & Zahl).Value
End If
Next Zahl

'Berechnet Gesamtauflage Neue Osnabrücker Zeitung
NOZ = 0
NOZAbo = 0
For Zahl = 1 To LastRow Step 1
If Range("C" & Zahl).Formula = "2002" Or Range("C" & Zahl).Formula = "1595" Or Range("C" & Zahl).Formula = "1469" Or Range("C" & Zahl).Formula = "1415" Or Range("C" & Zahl).Formula = "1662" Or Range("C" & Zahl).Formula = "1582" Or Range("C" & Zahl).Formula = "1598" Or Range("C" & Zahl).Formula = "1651" Then
NOZ = NOZ + Range("L" & Zahl).Value
NOZAbo = NOZAbo + Range("O" & Zahl).Value
End If
Next Zahl

'Berechnet Auflage Bild-Zeitung
Bild = 0
BildAbo = 0
BildBZWest = 0
BildBZWestAbo = 0
BildBZOst = 0
BildBZOstAbo = 0
BZ = 0
BZAbo = 0
For Zahl = 1 To LastRow Step 1
If Range("C" & Zahl).Formula = "9876" Then
BildBZWest = Range("L" & Zahl).Value
BildBZWestAbo = Range("O" & Zahl).Value
End If
Next Zahl
For Zahl = 1 To LastRow Step 1
If Range("C" & Zahl).Formula = "7092" Then
BildBZOst = Range("L" & Zahl).Value
BildBZOstAbo = Range("O" & Zahl).Value
End If
Next Zahl
For Zahl = 1 To LastRow Step 1
If Range("C" & Zahl).Formula = "9891" Then
BZ = Range("L" & Zahl).Value
BZAbo = Range("O" & Zahl).Value
Bild = BildBZOst + BildBZWest - BZ
BildAbo = BildBZWestAbo + BildBZOstAbo - BZAbo
End If
Next Zahl





'Definiert Ausnahmen für Titel mit Erscheinungsweise Mo-Fr
'IVW-Titelnr. 1775 = B.Z.
'IVW-Titelnr. 1036 = Handelsblatt
'IVW-Titelnr. 6751 = Die Welt gesamt (DIE WELT + WELT Kompakt)
'Bitte weitere Ausnahmen mit "Or Range("C" & Zahl).Formula = "Titel-Nr." ergänzen
For Zahl = 1 To LastRow Step 1
If Range("C" & Zahl).Formula = "1775" Or Range("C" & Zahl).Formula = "1036" Or Range("C" & Zahl).Formula = "6751" Then
 Range("H" & Zahl).Formula = "Platzhalter"
End If
Next Zahl

'Löscht alle Auflagen für Mo-Fr
For Zahl = 1 To LastRow Step 1
If Range("H" & Zahl).Formula = "Mo-Fr" Then
 Rows(Zahl).Clear
End If
Next Zahl

'Löscht alle Verlagsnummern mit 0
For Zahl = 1 To LastRow Step 1
If Range("G" & Zahl).Formula = "0" Then
 Rows(Zahl).Clear
End If
Next Zahl

'Sortiert Tabelle neu
Range("A1:Z10000").Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlYes

NewLastRow = Range("A" & Rows.Count).End(xlUp).Row

'Ersetzt Abkürzungen
For Zahl = 2 To NewLastRow Step 1
Zielzahl = Zahl + 4
Cells(Zahl, "H") = Replace(Cells(Zahl, "H"), "Mo-Sa", "Mo" & Chr(150) & "Sa")
Cells(Zahl, "H") = Replace(Cells(Zahl, "H"), "Mo-Fr", "Mo" & Chr(150) & "Fr")
Cells(Zahl, "H") = Replace(Cells(Zahl, "H"), "Mo-So", "Mo" & Chr(150) & "So")
Cells(Zahl, "H") = Replace(Cells(Zahl, "H"), "Platzhalter", "Mo" & Chr(150) & "Fr")
Cells(Zahl, "H") = Replace(Cells(Zahl, "H"), "woe", "wöchentlich")
Cells(Zahl, "H") = Replace(Cells(Zahl, "H"), "mtl", "monatlich")
'Erstellt Daten für Wikipedia
Worksheets("Wikipedia-Daten").Range("A" & Zielzahl).Value = "| " & Range("C" & Zahl).Value & " = {{#switch: {{{2}}}| Verk = " & Range("L" & Zahl).Value & "|Abo = " & Range("O" & Zahl).Value & "|Er = " & Range("H" & Zahl).Value & "}}"
Next Zahl
Range("C" & NewLastRow + 1).Value = "FT"
Range("D" & NewLastRow + 1).Value = "Fränkischer Tag, Gesamtauflage"
Range("L" & NewLastRow + 1).Value = FT
Worksheets("Wikipedia-Daten").Range("A" & NewLastRow + 5).Value = "| FT = {{#switch: {{{2}}}| Verk = " & FT & "|Abo = " & FTAbo & "| Er = " & "Mo" & Chr(150) & "Sa}}"
Range("C" & NewLastRow + 2).Value = "NOZ"
Range("D" & NewLastRow + 2).Value = "Neue Osnabrücker Zeitung, Gesamtauflage"
Range("L" & NewLastRow + 2).Value = NOZ
Worksheets("Wikipedia-Daten").Range("A" & NewLastRow + 6).Value = "| NOZ = {{#switch: {{{2}}}| Verk = " & NOZ & "|Abo = " & NOZAbo & "| Er = " & "Mo" & Chr(150) & "Sa}}"
Range("C" & NewLastRow + 3).Value = "1090"
Range("D" & NewLastRow + 3).Value = "Bild Zeitung, Gesamtauflage"
Range("L" & NewLastRow + 3).Value = Bild
Worksheets("Wikipedia-Daten").Range("A" & NewLastRow + 7).Value = "| 1090 = {{#switch: {{{2}}}| Verk = " & Bild & "|Abo = " & BildAbo & "| Er = " & "Mo" & Chr(150) & "Sa}}"
Worksheets("Wikipedia-Daten").Range("A" & NewLastRow + 8).Value = "}}<noinclude>"
Worksheets("Wikipedia-Daten").Range("A" & NewLastRow + 9).Value = "{{Dokumentation}}"
Worksheets("Wikipedia-Daten").Range("A" & NewLastRow + 10).Value = "</noinclude>"
Worksheets("IVW-Detail").Range("A1").Value = "<includeonly>([http://www.ivw.eu/aw/print/qa/titel/{{{1}}}?quartal%5B" & Vorquartaljahr & Vorquartal & "%5D=" & Vorquartaljahr & Vorquartal & "&quartal%5B" & Jahr & Quartal & "%5D=" & Jahr & Quartal & " Details und Quartalsvergleich auf ivw.eu])"
Worksheets("IVW-Detail").Range("A2").Value = "</includeonly><noinclude>{{Dokumentation}}"
Worksheets("IVW-Detail").Range("A3").Value = "</noinclude>"

'Kopiert Daten in Zwischenablage
Worksheets("Wikipedia-Daten").Activate
Worksheets("Wikipedia-Daten").Range("A1:A" & NewLastRow + 9).Copy

'ruft Wikipedia-Seite Vorlage:Metadaten_Auflagen_Zeitungen_DE auf
byWert = MsgBox("Möchten Sie die Daten in die Wikipedia-Vorlage einfügen?", 3)

 If StrPtr(byWert) = 0 Then
           Exit Sub
        ElseIf byWert = 6 Then
         ThisWorkbook.FollowHyperlink "http://de.wikipedia.org/w/index.php?title=Vorlage:Metadaten_Auflagen_Zeitungen_DE&action=edit"
       ElseIf byWert = 7 Then
    ElseIf byWert = 2 Then
    End If
    
'erstellt eigene Vorlage für Auflagen-Diagramm jeweils zum vierten Quartal
If Quartal = 4 Then
  byWert = MsgBox("Möchten Sie die Vorlage zum viertel Quartal erstellen?", 3)
  If StrPtr(byWert) = 0 Then
           Exit Sub
        ElseIf byWert = 6 Then
          ThisWorkbook.FollowHyperlink "http://de.wikipedia.org/w/index.php?title=Vorlage:Metadaten_Auflagen_Zeitungen_DE_" & Range("A2") & "&action=edit"
       ElseIf byWert = 7 Then
    ElseIf byWert = 2 Then
    End If
End If

'Ruft Vorlage:IVW-Detail auf
byWert = MsgBox("Möchten Sie die Vorlage für IVW-Details erstellen und einfügen?" & vbLf & "Achtung: Bitte zuerst Zwischenablage mit den Auflagenzahlen einfügen!", 3)

 If StrPtr(byWert) = 0 Then
           Exit Sub
        ElseIf byWert = 6 Then
        Worksheets("IVW-Detail").Activate
        Worksheets("IVW-Detail").Range("A1:A3").Copy
        ThisWorkbook.FollowHyperlink "http://de.wikipedia.org/w/index.php?title=Vorlage:IVW-Detail&action=edit"
       ElseIf byWert = 7 Then
    ElseIf byWert = 2 Then
    End If
    
'ruft Vorlage zum Auflagen-Diagramm auf
 If Quartal = 4 Then
  byWert = MsgBox("Möchten Sie die Vorlage Auflagen-Diagramm aktualisieren?", 3)
  
  If StrPtr(byWert) = 0 Then
           Exit Sub
        ElseIf byWert = 6 Then
        ThisWorkbook.FollowHyperlink "http://de.wikipedia.org/w/index.php?title=Vorlage:Auflagen-Diagramm&action=edit"
       Exit Sub
       ElseIf byWert = 7 Then
    Exit Sub
    ElseIf byWert = 2 Then
    Exit Sub
    End If
    End If
End Sub


Public Function CheckSheet(Name As String) As Boolean
 
  On Error Resume Next
 
  CheckSheet = Not CBool(Name <> ThisWorkbook.Worksheets(Name).Name)
 
End Function
Abgerufen von „https://de.wikipedia.org/w/index.php?title=Benutzer:Schreibkraft/Excel-Meta-Auflagen-Zeitungen-DE.vba&oldid=234780063“