Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

VBA - Makro zur Erstellung eines alphabetisierten Stichwortverzeichnisses in Excel

Frage Entwicklung VB for Applications

Mitglied: Rom682013

Rom682013 (Level 1) - Jetzt verbinden

08.03.2013, aktualisiert 13.03.2013, 1779 Aufrufe, 3 Kommentare

Liebe Profis,

wer kann mir von Euch helfen. Ich habe folgendes Problem:

In einer Excel-Arbeitsmappe habe ich unter anderem drei Arbeitsblätter: System, Schlagwörter und Stichwortverzeichnis. Nun soll im Arbeitsblatt „System“ in der Spalte A nach Schlagwörtern, die in Arbeitsblatt „Schlagwörter“ Spalte A ab Zelle 3 enthalten sind, gesucht werden. Wenn wahr, dann soll die ganze Zeile, da auch Einträge in Spalten B bis D vorhanden sind, kopiert und in Arbeitsblatt „Stichwortverzeichnis“ (bislang leer) eingefügt werden. Zudem soll variabel gesucht werden, d. h. Schlagwort „Verzeichnis“ Ausgabe „Verzeichnis“ und/oder „Verzeichnisses“ und/oder „Verzeichnisse“ bzw. Schlagwort „Auf- und Abbauten“ Ausgabe „ Auf- und Abbauten“ und/oder „auf- und abbau“. Das Arbeitsblatt „Stichwortverzeichnis“ soll wie folgt aufgebaut werden:

A
Such-Schlagwort
Ausgabe aus „System“
Ausgabe aus „System“
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
usw.

B
Such-Schlagwort
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
usw.

C
Such-Schlagwort
Ausgabe aus „System“
usw.

bis Z


Ich scheitere bereits beim Kopieren in das Arbeitsblatt „Stichwortverzeichnis“. Derzeit wird alles eingefügt, nur nicht das wonach ich suche.

Mein derzeitiges Makro lautet:

Sheets("SysKopie").Activate
Dim A, B, C, D, E, F
Dim Suchbegriff As String
Sheets("SysKopie").Select

A = Range(Sheets("Schlagwörter").Cells(1, 1), Sheets("Schlagwörter").Cells(1, 1).End(xlDown)).Rows.Count

B = Range(Sheets("SysKopie").Cells(1, 1), Sheets("SysKopie").Cells(1, 1).End(xlDown)).Rows.Count

For C = 2 To B
Suchbegriff = Sheets("Schlagwörter").Cells(C, 1).Value
For D = 2 To A
Cells(D, 1).Select 'kann man weglassen, man sieht aber wo man ist
E = Cells(D, 1).Value
F = InStr(1, E, Suchbegriff, vbTextCompare)
If F > 0 Then
ActiveCell.EntireRow.Copy
Sheets("Stichwortverzeichnis").Range("A" & zelle.Row) = zelle.Offset(0, 1)
End If
F = 0
Next D
Next C
Sheets("Stichwortverzeichnis").Activate
Cells(3, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _
8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21), Header:=xlNo

Und bleibt im Testlauf bei der Zeile
Sheets("Stichwortverzeichnis").Range("A" & zelle.Row) = zelle.Offset(0, 1)
stehen.

Wer kann mir da helfen. Im Voraus besten Dank!

Viele Grüße
Rom682013
Mitglied: colinardo
08.03.2013 um 12:28 Uhr
Hi Rom682013,
hier solltest du Antworten auf deine Fragen finden: http://www.administrator.de/contentid/202195
Grüße Uwe
Bitte warten ..
Mitglied: bastla
15.03.2013, aktualisiert um 17:14 Uhr
Hallo Rom!

Auf Basis der per Mail erhaltenen Beispieldatei könnte das schematisch etwa so gehen:
01.
Sub Stichwortverzeichnis_erstellen() 
02.
 
03.
SchlagTabelle = "Schlagwörter" 
04.
QuellTabelle = "SysKopie" 
05.
ZielTabelle = "Stichwortverzeichnis" 
06.
 
07.
SchlagAb = "A3" 'Zelle mit erstem Schlagwort 
08.
QuellSpalte = "A" 'erste Datenspalte der Quelldatei - hier wird gesucht 
09.
QuellSpaltenAnzahl = 3 'Anzahl zu kopierender Spalten 
10.
 
11.
ZielAb = "A3" 'erste Zelle der Zieldatei 
12.
 
13.
Set STab = Worksheets(SchlagTabelle) 
14.
Set QTab = Worksheets(QuellTabelle) 
15.
Set ZTab = Worksheets(ZielTabelle) 
16.
 
17.
SZeile = STab.Range(SchlagAb).Row 
18.
SSpalte = STab.Range(SchlagAb).Column 
19.
 
20.
ZZeile = ZTab.Range(ZielAb).Row 
21.
ZSpalte = ZTab.Range(ZielAb).Column 
22.
 
23.
Application.StatusBar = True 'Anzeige in Statusleiste aktivieren 
24.
Schlagwort = STab.Cells(SZeile, SSpalte).Value 'erstes Schlagwort auslesen 
25.
Do While Schlagwort <> "" 'wiederholen. solange noch Schlagwörter gefunden werden 
26.
    Buchstabe = UCase(Left(Schlagwort, 1)) 'Anfangsbuchstabe 
27.
    If Buchstabe <> BuchstabeZuletzt Then 'neuer Buchstabe? 
28.
        ZTab.Cells(ZZeile, ZSpalte).Value = Buchstabe 'Buchstaben eintragen ... 
29.
        ZTab.Cells(ZZeile, ZSpalte).Font.Bold = True '... fett formatieren ... 
30.
        BuchstabeZuletzt = Buchstabe '... und merken 
31.
        ZZeile = ZZeile + 1 'nächste Zeile in Zieldatei 
32.
        Application.StatusBar = "Bearbeite Buchstabe:  " & Buchstabe 'Aktuell bearbeiteten Buchstaben in der Stautsleiste anzeigen 
33.
    End If 
34.
    Set c = QTab.Columns(QuellSpalte).Find(Schlagwort, LookIn:=xlValues) 'gesamte Spalte durchsuchen 
35.
    If Not c Is Nothing Then 'gefunden? 
36.
        ZTab.Cells(ZZeile, ZSpalte).Value = Schlagwort 'Schlagwort eintragen ... 
37.
        ZTab.Cells(ZZeile, ZSpalte).Font.Bold = True '... und fett formatieren 
38.
        STab.Cells(SZeile, SSpalte).Offset(0, 1).Value = "vorhanden" 
39.
        ZZeile = ZZeile + 1 'nächste Zeile der Zieltabelle 
40.
        Zuerst = c.Address 'erste Fundstelle merken 
41.
        Do 
42.
            c.Resize(1, QuellSpaltenAnzahl).Copy ZTab.Cells(ZZeile, ZSpalte) 
43.
            ZZeile = ZZeile + 1 'nächste Zeile in Zieldatei 
44.
            Set c = QTab.Columns(QuellSpalte).FindNext(c) 'weitersuchen 
45.
        Loop While Not c Is Nothing And c.Address <> Zuerst 'bis nix oder erster Fund gefunden wird 
46.
        ZZeile = ZZeile + 1 'für Leerzeile in Zieldatei 
47.
    Else 'Schlagwort nicht gefunden 
48.
        STab.Cells(SZeile, SSpalte).Offset(0, 1).Value = "nicht vorhanden" 
49.
    End If 
50.
    SZeile = SZeile + 1 'nächste Zeile in Schlagworttabelle 
51.
    Schlagwort = STab.Cells(SZeile, SSpalte).Value 'nächstes Schlagwort auslesen 
52.
Loop 
53.
Application.StatusBar = False 'Statusleistenanzeige abschalten 
54.
MsgBox "Fertig." 
55.
End Sub
Zusätzliche Formatierungen, andere Suchparameter (Zeile 34), etc bekommst Du ja bei Bedarf vielleicht auch selbst hin ...

Grüße
bastla

[Edit] Statusleistenanzeige hinzugefügt [/Edit]
Bitte warten ..
Mitglied: Rom682013
17.03.2013 um 22:27 Uhr
Hallo bastla,

vielen, vielen lieben Dank! Das Makro funktioniert bestens. Ich hätte das auf die Schnelle nie so hinbekommen. Danke auch für die Kommentierungen. Den „Rest“ bekomme ich selber hin.
Ich sag nur: „You’re the best champion of the year“.

Viele Grüße
Rom
Bitte warten ..
Neuester Wissensbeitrag
Microsoft

Lizenzwiederverkauf und seine Tücken

(5)

Erfahrungsbericht von DerWoWusste zum Thema Microsoft ...

Ähnliche Inhalte
Microsoft Office
gelöst CSV-Datei mit einem VBA Makro in Excel einlesen und leicht anpassen (5)

Frage von JoSiBa zum Thema Microsoft Office ...

VB for Applications
gelöst VBA-Makro verschwindet nach Speichern (5)

Frage von lupi1989 zum Thema VB for Applications ...

Heiß diskutierte Inhalte
LAN, WAN, Wireless
FritzBox, zwei Server, verschiedene Netze (17)

Frage von DavidGl zum Thema LAN, WAN, Wireless ...

Windows Netzwerk
Windows 10 RDP geht nicht (16)

Frage von Fiasko zum Thema Windows Netzwerk ...

Windows Server
Outlook Verbindungsversuch mit Exchange (15)

Frage von xbast1x zum Thema Windows Server ...