Hi Sascha,
ein klein wenig habe ich noch geändert am Code:
Option Explicit
Sub SuchFormat3()
Dim wks As Worksheet, rngC As Range, oDic As Object, arT
Dim cc As Long, ii As Long
Const ZeileUeb As Long = 6
Const TexteUeb As String = "X|Z|G|H"
Set oDic = CreateObject("Scripting.Dictionary")
arT = Split(TexteUeb, "|")
For Each wks In ActiveWorkbook.Worksheets
With wks
oDic.Add .Name & " wird durchsucht", "" ' vielleicht nützlich
If Not Intersect(.UsedRange, .Columns(2)) Is Nothing Then
For Each rngC In Intersect(.UsedRange, .Columns(2)) ' Spalte B=2 immer
Select Case rngC.NumberFormat
Case "General", "@"
Case Else
oDic.Add .Name & "!" & rngC.Address(0, 0), ""
End Select
Next rngC
End If
For cc = 1 To .Cells(ZeileUeb, .Columns.Count).End(xlToLeft).Column
If cc 2 Then
For ii = 0 To UBound(arT) ' Spalten mit best. Überschriften
If .Cells(ZeileUeb, cc) = arT(ii) Then
For Each rngC In Intersect(.UsedRange, .Columns(cc))
Select Case rngC.NumberFormat
Case "General", "@"
Case Else
oDic.Add .Name & "!" & rngC.Address(0, 0), ""
End Select
Next rngC
End If
Next ii
End If
Next cc
End With
Next wks
Worksheets.Add Before:=Worksheets(1)
With ActiveSheet.Columns(1)
.NumberFormat = "@"
.Cells(1).Resize(oDic.Count) = Application.Transpose(oDic.Keys)
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, _
OtherChar:="!", FieldInfo:=Array(Array(1, 2), Array(2, 2))
End With
End Sub
Sub SuchZahlen()
Dim wks As Worksheet, rngC As Range, oDic As Object, arT
Dim cc As Long, ii As Long
Const ZeileUeb As Long = 6
Const TexteUeb As String = "X|Z|G|H"
Set oDic = CreateObject("Scripting.Dictionary")
arT = Split(TexteUeb, "|")
For Each wks In ActiveWorkbook.Worksheets
With wks
oDic.Add .Name & " wird durchsucht", "" ' vielleicht nützlich
If Not Intersect(.UsedRange, .Columns(2)) Is Nothing Then
For Each rngC In Intersect(.UsedRange, .Columns(2)) ' Spalte B=2 immer
If Application.IsNumber(rngC) Then _
oDic.Add .Name & "!" & rngC.Address(0, 0), rngC.Value2
Next rngC
End If
For cc = 1 To .Cells(ZeileUeb, .Columns.Count).End(xlToLeft).Column
If cc 2 Then
For ii = 0 To UBound(arT) ' Spalten mit best. Überschriften
If .Cells(ZeileUeb, cc) = arT(ii) Then
For Each rngC In Intersect(.UsedRange, .Columns(cc))
If Application.IsNumber(rngC) Then _
oDic.Add .Name & "!" & rngC.Address(0, 0), rngC.Value2
Next rngC
End If
Next ii
End If
Next cc
End With
Next wks
Worksheets.Add Before:=Worksheets(1)
With ActiveSheet.Columns(1)
.NumberFormat = "@"
.Cells(1).Resize(oDic.Count) = Application.Transpose(oDic.Keys)
.Cells(1).Offset(, 2).Resize(oDic.Count) = Application.Transpose(oDic.Items)
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, _
OtherChar:="!", FieldInfo:=Array(Array(1, 2), Array(2, 2))
End With
End Sub
"SuchZahlen" kannst du ja auch mal laufen lassen, vielleicht ist das ja auch interessant...
Den den "Code kurz zu kommentieren" ist nicht so einfach. Wo aufsetzen, wo anfangen, wo aufhören?
Wie sind deine Vorkenntnisse?
Besser wäre es, du würdest konkrete Fragen stellen. Zunächst dir, dann der VBA-Hilfe,
der Recherche hier im Forum, Google o.ä., und dann - wenn noch nötig - hier in einem Beitrag. :-)
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich und: Schönes Wochenende allerseits!