AW: mit der Funktion VarType()
29.09.2014 13:15:23
Sparrow
Hey,
ich sag mal Jein - der folgende Code soll dementsprechend geändert werden dass nicht das Format der Zelle betrachtet wird sondern "als Text gespeicherte Zahl" oder Zahl (beides ist Format Standard)
Gibt es da eine Möglichkeit? Nochmals vielen Dank für die Hilfe..
Vg
Sascha
Option Explicit
Sub SuchFormat()
Dim wks As Worksheet, rng As Range, Dic As Object, arT
Dim cc As Long, ii As Long
Const ZeileUeb As Long = 6 'Zeile 6 durchsuchen nach...
Const TexteUeb As String = "X"
'nach diesen Spaltennamen
Set Dic = CreateObject("Scripting.Dictionary")
arT = Split(TexteUeb, "|") 'Die Überschriften der Spalten analysieren, bzw. die Ü _
berschriften splitten
For Each wks In ActiveWorkbook.Worksheets 'Jede Tabelle der Datei ansprechen
With wks
Dic.Add .Name & " wird durchsucht", "" 'Tabelle X wird durchsucht
If Not Intersect(.UsedRange, .Columns(2)) Is Nothing Then
For Each rng In Intersect(.UsedRange, .Columns(2)) ' Spalte B=2 untersuche ich immer
Select Case rng.NumberFormat 'hat die Zelle ein Zahlenformat?
Case "General", "@" 'oder ein Text bzw Standard-Format
Case Else
Dic.Add .Name & "!" & rng.Address(0, 0), "" 'falls Zahl - Name der Tabelle _
sowie Adresse ausgeben
End Select
Next rng
For cc = 1 To .Cells(ZeileUeb, .Columns.Count).End(xlToLeft).Column 'Untersuche Zeile _
6 bis zur letzten Spalte
For ii = 0 To UBound(arT) ' Spalten mit best. Überschriften
If .Cells(ZeileUeb, cc) = arT(ii) Then ' hat eine Spalte die gesuchte Ü _
berschrift, dann
For Each rng In Intersect(.UsedRange, .Columns(cc))
Select Case rng.NumberFormat 's.o.
Case "General", "@"
Case Else
Dic.Add .Name & "!" & rng.Address(0, 0), ""
End Select
Next rng
End If
Next ii
Next cc
End If
End With
Next wks
Worksheets.Add Before:=Worksheets(1) 'Vor der aktuellen Tabelle eine neue erstellen
With ActiveSheet.Columns(1) 'bringe die gespeicherten Infos zu der ersten Zelle einer _
neuen Tabelle
.NumberFormat = "@"
.Cells(1).Resize(Dic.Count) = Application.Transpose(Dic.Keys) 'gesicherte Daten in _
horizontale Form bringen
.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