Tabelle transponieren & zusätzliche Infos auslesen

Hallo zusammen,
ich muss hier eine super schwere vba Aufgabe lösen und bin mittlerweile am verzweifeln. Meine Kenntnisse sind einfach nicht ausreichend um das hin zu bekommen. An einigen Teilaspekten habe ich mich versucht, scheitere aber schon bei den eher einfachen Sachen. Die schwierigen Fragen weiss ich noch gar nicht ob die sich lösen lassen.
Im Anhang ist die Aufgabe im zweiten Reiter kurz beschrieben. Schon das zuverlässige Eingrenzen der einzeln zu bearbeitenden Blöcke, und diese dann Stück für Stück auszulesen hat mich an meine Grenzen gebracht. Hier allerdings ein guter Link der im Prinzip glaube ich gut ist, um diesen Teilaspekt der Aufgabe zu lösen:
https://stackoverflow.com/questions/22075988/detect-merged-cells-in-vba-excel-with-mergearea
Dann habe ich noch sehr lange gegooglt um herauszufinden, ob es in vba eine Funktion gibt um ein im Schriftsatz (Font) fehlendes Zeichen (Fragezeichen in einem Kästchen wird dann angezeigt) zu erkennen? Das mit =SÄUBERN() [=CLEAN()] hat bei mir nicht funktioniert. Warum weiss ich nicht. Ich habe zwei Links gefunden die etwas sein könnten, aber mit denen kann ich nichts anfangen.
https://social.technet.microsoft.com/Forums/ie/en-US/a15bd2b9-a023-4473-b1a0-7afeb261bee7/question-mark-in-a-box-for-some-not-for-others?forum=excel
https://stackoverflow.com/questions/3488242/microsoft-word-change-font-of-characters-missing-in-default-font
Schafft es irgend jemand das zu lösen?
Hier der Anhang: https://www.herber.de/bbs/user/114808.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Luc,
vielen Dank für deine Antwort. Das war ein großer Schritt in die richtige Richtung. Das Konzept des Macros denke ich steht. Und auch wenn es nicht möglich ist die [?] zu erkennen so könnte ich vielleicht mit einem Teilergebnis schon mal etwas anfangen. Das [?] Problem verschiebe ich erst mal. Irgenwo hatte ich jetzt aber noch gelsen, dass ich - wenn es sich um die genaue reproduktion des Zellinhaltes (der einzelnen Character handelt - ich vielleich besser mit Dictionary arbeite als mit arrays. Jetzt dachte ich daher probiere ich besser mal beiders.
Leider ist der Code den ich bis jetzt zusammen geschrieben habe nicht lauffähig. Ich bekommen ein Error:
Ungültiger Prozeduraufruf oder ungültiges Argument für die Zeile:

Set Matrizen = Union(Matrizen, .Range(Cells(z(i) + 1, 2).Address & ":" & Cells(z(i + 1) - 1, 18).Address))

Kannst du mir hier weiterhelfen? Hier der ganze code:

Option Explicit
Sub FindGrayCells_2()
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet
'Dim chkrng As Range
Dim Matrizen As Range
Dim Dic As Object ',RegEx As Object
Dim z(), ZellInfos(), a
Dim x&, i&, j&, n&, m&, o&, spalte&, zeile&
Dim KontrollNachricht As String
n = 0
m = 0
o = 0
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
'Set RegEx = CreateObject("vbscript.regexp")
With Ws
For x = 1 To 1000
If .Cells(x, 2).MergeArea.Columns.Count = 17 Then
n = n + 1
ReDim Preserve z(n)
z(n) = x
End If
Next x
For i = 1 To n
Set Matrizen = Union(Matrizen, .Range(Cells(z(i) + 1, 2).Address & ":" & Cells(z(i + _
1) - 1, 18).Address))
Next i
For i = 1 To Matrizen.Areas.Count
a = Matrizen.Areas(i)
For zeile = LBound(a, 1) To UBound(a, 1)
o = o + 1
For spalte = LBound(a, 2) To UBound(a, 2)
m = m + 1
ReDim Preserve ZellInfos(m, 6)
'Zellwert1
Dic.Add a(zeile + 1, spalte + 1), ""
'Zellenblockname
ZellInfos(m, 1) = a(-1, 2).Value
'ZeilenName
ZellInfos(m, 2) = a(zeile + 1, 1).Value
'Spaltenname
ZellInfos(m, 3) = a(zeile, spalte + 1).Value
'Zellwert2
ZellInfos(m, 4) = a(zeile + 1, spalte + 1).Value
'ZellenHintergrundfarbe
ZellInfos(m, 5) = a(zeile + 1, spalte + 1).bgcolor
'Enthält Zelle beide eckige Klammern?
For j = 1 To 6
KontrollNachricht = KontrollNachricht & ZellInfos(m, j) & vbNewLine
Next j
MsgBox "Hier die Kontrollausgabe:" & vbNewLine & KontrollNachricht
Next spalte
Next zeile
Next i
End With
'Gehe zum Sheet(NEU) und füge die Daten in die gewünschte Zelle hinzu
Erase z: Erase ZellInfos
Allcellsareempty:
Set Wb = Nothing
Set Ws = Nothing
'    Set chkrng = Nothing
Set Dic = Nothing
'    Set RegEx = Nothing
Application.ScreenUpdating = True
End Sub

Funktion IstZeichenInSchriftartEnthalten (Zeichen As ?, Schriftart as ?) as boolean End Function Sub Main() Dim Zeichen as ?String Dim Schriftart as ? Dim Enthalten as boolean Zeichen = .... Cells(x,y) Schriftart = ? Enthalten = IstZeichenInSchriftartEnthalten(Zeichen,Schriftart) End Sub

Sub FindGrayCells_2() Const adGesBerSp1$ = "B31:B357" Dim Wb As Workbook: Set Wb = ThisWorkbook Dim Ws As Worksheet: Set Ws = Wb.ActiveSheet ' Dim chkrng As Range Dim a As Range, Matrizen As Range, xZ As Range Dim Dic As Object ',RegEx As Object Dim ZellInfos() Dim i&, j&, n&, m&, o&, spalte&, z&(), zeile& Dim KontrollNachricht$ Application.ScreenUpdating = False Set Dic = CreateObject("Scripting.Dictionary") ' Set RegEx = CreateObject("vbscript.regexp") With Ws For Each xZ In .Range(adGesBerSp1) If xZ.MergeCells Then ReDim Preserve z(n) z(n) = xZ.Row n = n + 1 End If Next xZ Set Matrizen = .Range(.Cells(z(0) + 1, 2), .Cells(z(1) - 1, 18)) For i = LBound(z) + 1 To UBound(z) - 1 Set Matrizen = Union(Matrizen, .Range(.Cells(z(i) + 1, 2), _ .Cells(z(i + 1) - 1, 18))) Next i With .Range(adGesBerSp1) Set Matrizen = Union(Matrizen, Ws.Range(Ws.Cells(z(i) + 1, 2), _ Ws.Cells(.Cells(.Rows.Count).Row, 18))) 'alternativ: ' Set Matrizen = Union(Matrizen, Ws.Range(Ws.Cells(z(i) + 1, 2), _ Ws.Range(Split(adGesBerSp1, ":")(1)))) End With End With '… End Sub

Beliebteste Forumthreads (12 Monate)

Tabelle transponieren & zusätzliche Infos auslesen

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread