01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74 |
|
Option Explicit
Sub Sehenswürdigkeiten()
' <<< Nur über Schaltfläche aktivieren! >>>
Dim Objekt_Finden As Object
Dim sArr() As String, sBer() As String
Dim Spalte_ErsteAdresse As String, Spalte_Suchen As String
Dim i As Integer, n As Integer, Ausgabe_Zeile As Long
Dim Ziel As Worksheet, Quelle As Worksheet
Const csSpalten = "A1,F1,B1,G1,H1,C1,AC1,AA1,U1,V1,AH1,AI1"
Const csErsetz = "Oktoberfest,OF,Fischmarkt,FM"
' <<< Stammdatendatei öffnen >>>
Workbooks.Open ("E:\Stammdaten.xlsx")
' Quell- und Zielblatt setzen
Set Quelle = Worksheets("Datenerfassung")
Set Ziel = ThisWorkbook.Worksheets("München")
sArr = Split(csErsetz, ",")
sBer = Split(csSpalten, ",")
' <<< Daten in Zieldatei löschen >>>
Ziel.Range("A23:L82").ClearContents
' <<< Text aus Button als Suchbegriff festlegen >>>
Spalte_Suchen = Ziel.Buttons(Application.Caller).Caption
If Spalte_Suchen = "" Then Exit Sub
' <<< Erste Ausgabezeile in der Zieldatei >>>
Ausgabe_Zeile = 22
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
' Erstes Feld mit dem Suchbegriff suchen
Set Objekt_Finden = Quelle.Range("E:E").Find(Spalte_Suchen, LookIn:=xlValues, LookAt:=xlWhole)
If Not Objekt_Finden Is Nothing Then
Spalte_ErsteAdresse = Objekt_Finden.Address
Do
Ausgabe_Zeile = Ausgabe_Zeile + 1
For n = 0 To UBound(sBer)
' Quelle.Range(Replace(sBer(n), "1", Objekt_Finden.Row)).Copy _
Ziel.Cells(Ausgabe_Zeile, n + 1)
' Nur Werte
Ziel.Cells(Ausgabe_Zeile, n + 1).Value _
= Quelle.Range(Replace(sBer(n), "1", Objekt_Finden.Row)).Value
Next n
' <<< Ersetze Begriff von Quellblatt in Zielblatt durch anderen Begriff >>>
With Ziel.Cells(Ausgabe_Zeile, "D")
For i = 0 To UBound(sArr) - 1 Step 2
.Value = Replace(.Value, sArr(i), sArr(i + 1))
Next i
End With
' <<< Schleife für nächsten Suchbegriff >>>
Set Objekt_Finden = Quelle.Range("E:E").FindNext(Objekt_Finden)
Loop While Not Objekt_Finden Is Nothing And Objekt_Finden.Address <> Spalte_ErsteAdresse
End If
Workbooks("Stammdaten.xlsx").Close
Ziel.Activate
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
|