Live-Forum - Die aktuellen Beiträge
Datum
Titel
15.07.2024 16:00:57
15.07.2024 15:41:38
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro: Nach Überschr. suchen und in neues AB

Makro: Nach Überschr. suchen und in neues AB
01.02.2016 12:00:15
Christoph

Hallo zusammen.
Ich würde mich bei folgendem über Unterstützung freuen.
Ziel:
- Überschrift suchen und spalte markieren. Markiertes dann in neues Arbeitsblatt (z.B. "Z") einfügen (definierte Spalte z.B. immer C).
Konkret: "ASDF" in Überschriften aller Arbeitsblätter (außer "Z") suchen und spalte kopieren. Das kopierte dann in "Z" Arbeitsblatt einfügen (z.B. immer in Spalte C)
Code bisher:


Sub Makro13()
' Makro13 Makro
Cells.Find(What:=" asdf", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
Columns("C:C").Select 'Hier ist der Fehler er soll nicht c:c auswählen sondern die gesuchte  _
_
_
_
Spalte der Überschrift die ich oben gefunden habe
Selection.Copy
Sheets("Tabelle1").Select
ActiveSheet.Paste
End Sub

Probleme:
- Da ich es geklickt habe (Makrorecorder) nimmt er C und nicht die gefundene Spalte zu der gefundenen Zeile.
- Wie kann ich mehrere Begrifffe hintereinander suchen und das Makro durchführen?
Vielen Dank für eure Unterstützung.
Viele Grüße
Nuwajz

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
01.02.2016 13:11:11
UweD
Hallo
so?

Sub Suchen()
Dim WS As Worksheet
Dim C
For Each WS In Worksheets
If WS.Name <> "Z" Then
Set C = WS.Rows("1:1").Find("ASDF", LookIn:=xlValues)
If Not C Is Nothing Then
WS.Columns(C.Column).Copy
Sheets("Z").Columns(3).Insert Shift:=xlToRight
Application.CutCopyMode = False
Else
MsgBox "In Blatt '" & WS.Name & "' Nichts gefunden!"
End If
End If
Next
End Sub
Gruß UweD

AW: Makro: Nach Überschr. suchen und in neues AB
01.02.2016 13:57:18
UweD
Mehrere Begriffe nacheinander

Sub Suchen()
Dim WS As Worksheet
Dim C, FFind(), i As Integer
FFind = Array("ASDF", "UDD", "AAA")
For Each WS In Worksheets
If WS.Name <> "Z" Then
For i = 0 To UBound(FFind)
Set C = WS.Rows("1:1").Find(FFind(i), LookIn:=xlValues)
If Not C Is Nothing Then
WS.Columns(C.Column).Copy
Sheets("Z").Columns(3).Insert Shift:=xlToRight
Application.CutCopyMode = False
Else
MsgBox FFind(i) & " in Blatt '" & WS.Name & "' Nichts gefunden!"
End If
Next i
End If
Next
End Sub
Gruß UweD

Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
02.02.2016 10:52:50
Christoph
Hallo UweD. Super! Vielen Dank schon mal bis dahin.
Funktioniert fast komplett. Hab mal noch die gut gedachte, aber bei zu vielen Begriffen nicht sinnvolle Box rausgelöscht.
Sub Suchen()
Dim WS As Worksheet
Dim C, FFind(), i As Integer
FFind = Array("qi106_zulauf_str2_ph_wert", "UDD", "AAA")
For Each WS In Worksheets
If WS.Name <> "Z" Then
For i = 0 To UBound(FFind)
Set C = WS.Rows("1:1").Find(FFind(i), LookIn:=xlValues)
If Not C Is Nothing Then
WS.Columns(C.Column).Copy
Sheets("Z").Columns(2).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
Next i
End If
Next
End Sub
Eins benötige ich jedoch noch. Vielleicht weist du da auch weiter.
Es soll z.B. UDD immer in Spalte C, AAA immer in Spalte D. Dann sind halt sonst dazwischen Lücken wenn er es nicht findet. Grund ist der, dass sich da direkt eine Grafik anschließt.

Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
02.02.2016 13:21:54
UweD
Hilft das ??

Sub Suchen()
Dim WS As Worksheet
Dim C, FFind(), FWo(), i As Integer
FFind = Array("qi106_zulauf_str2_ph_wert", "UDD", "AAA")
FWo = Array(2, 3, 4) 'Zielspalten zu FFind
For Each WS In Worksheets
If WS.Name <> "Z" Then
For i = 0 To UBound(FFind)
Set C = WS.Rows("1:1").Find(FFind(i), LookIn:=xlValues)
If Not C Is Nothing Then
WS.Columns(C.Column).Copy Sheets("Z").Columns(FWo(i))
End If
Next i
End If
Next
End Sub
FWo = Array(2, 3, 4) sind dabei die Spalten, wo die gefundenen Werde reingeschrieben werden sollen. Vorhandene Werte werden aber überschrieben
LG UweD

Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
02.02.2016 19:24:07
Christoph
Hallo UweD.
Vielen lieben Dank!
Nach aktuellem Stand ist das genau das, was ich wollte!
Nach der Lösung hätte ich ja ewig gesucht. Vielen Dank erneut!
Nur so aus Neugier.
Könnte ich nach FFind noch eine zeile einfügen, die die erste gesuchte Bezeichnung in der Titelleiste umnennt?
Also im konkreten Fall: "UDD" in z.B. "QI107irgendwas"?
Wichtig wäre hier natürlich erneut, dass er nur die jeweils gefundenen umnennt.
Wenn
Gefunden (asdf, fdsa, ölkj)
wird zu (qwert, trewq, uiop)
Problematisch wäre natürlich wenn folgendes passiert:
gefunden (asdf, ölkj)
wird zu (qwer, trewq)
letzteres wäre falsch.

Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
02.02.2016 20:16:41
UweD
Ja, das geht natürlich auch.
Wird so vor dem kopieren umbenannt

Sub Suchen()
Dim WS As Worksheet
Dim C, FFind(), NNeu(), FWo(), i As Integer
FFind = Array("BLA", "UDD", "AAA", "HUGO")
NNeu = Array("qi106_zulauf", "UDD Neu", "AAA", "Neu_HUGO") 'Umbenennung fü FFind
FWo = Array(2, 3, 4) 'Zielspalten zu FFind
For Each WS In Worksheets
If WS.Name <> "Z" Then
For i = 0 To UBound(FFind)
Set C = WS.Rows("1:1").Find(FFind(i), LookIn:=xlValues)
If Not C Is Nothing Then
WS.Range(C.Address) = NNeu(i)
WS.Columns(C.Column).Copy Sheets("Z").Columns(FWo(i))
End If
Next i
End If
Next
End Sub
LG UWeD

Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
02.02.2016 23:48:15
Christoph
Danke dir.
Ja, das umbenennen klappt. Vielleicht habe ich das auch nicht korrekt ausgedrückt, aber in den Blättern außer Reiter "Z" soll es nicht umbenannt werden.
Grund ist der, dass die ursprünglichen Dateien so belassen werden sollen.
Also das ist jetzt richtig mit dem umbenennen, nur würde ich es gerne noch nur auf "Z" beschränken.
Ich könnte ja als zweites Makro das finden und mit anderem Namen ersetzen starten... danach. Aber wie würde ich es nur auf "Z" beschränken? Wenn es natürlich mit einem Makro möglich ist .... perfekt :)
Vielen Dank dir erneut!

AW: Makro: Nach Überschr. suchen und in neues AB
03.02.2016 08:47:38
UweD
OK.
Das Umbenennen erfolgt dann Nach dem kopieren.

Option Explicit
Sub Suchen()
Dim WS As Worksheet
Dim C, FFind(), NNeu(), FWo(), i As Integer
FFind = Array("BLA", "UDD", "AAA", "HUGO")
NNeu = Array("qi106_zulauf", "UDD Neu", "AAANeu", "Neu_HUGO") 'Umbenennung fü FFind
FWo = Array(2, 3, 4) 'Zielspalten zu FFind
For Each WS In Worksheets
If WS.Name <> "Z" Then
For i = 0 To UBound(FFind)
Set C = WS.Rows("1:1").Find(FFind(i), LookIn:=xlValues)
If Not C Is Nothing Then
WS.Columns(C.Column).Copy Sheets("Z").Columns(FWo(i))
Sheets("Z").Cells(1, FWo(i)) = NNeu(i)
End If
Next i
End If
Next
End Sub

Gruß UweD

Anzeige
AW: Makro: Nach Überschr. suchen und in neues AB
03.02.2016 10:33:12
Christoph
Hallo UweD.
Wunschlos glücklich!
Vielen Dank dir!

319 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige