Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
992to996
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
992to996
992to996
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Ziffernblöcke aus Text extrahieren

Ziffernblöcke aus Text extrahieren
15.07.2008 09:48:00
Claus
Hallo zusammen,
immer wieder habe ich Daten aus einem Word-Dokument, in denen sich Materialnummern verstecken.
Es ist als Tabelle aufgebaut. Ich würde gerne diese mehreren Word-Tabellenfenster kopieren, in eine Excel-Datei einfügen und dann auf Knopfdruck (Makro) in einem separaten Tabellenblatt alle enthaltenen Nummernblöcke als jeweils eine Zelle erhalten.
Also ein Makro, der alle Zellen eines Tabellenblatts durchscannt und entsprechend alle Ziffern blockweise erkennt und rausgibt. Würde mir einiges an Arbeit ersparen.
LG
Claus

22
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Ziffernblöcke aus Text extrahieren
15.07.2008 10:09:00
Caruso
Hallo Claus
Tipp von mir: Eine Musterdatei erhöht die Antwortgeschwindigkeit und -genauigkeit.
Gruß
Carlo

AW: Ziffernblöcke aus Text extrahieren
15.07.2008 10:19:00
Claus
Habe eine Musterdatei hochgeladen, aber wo ist die jetzt? Wie kann ich den link drauf machen?

AW: Ziffernblöcke aus Text extrahieren
15.07.2008 10:22:00
David
den Link bekommst du direkt nach dem Hochladen und den musst du in dein Posting reinkopieren.
Gruß
David

AW: Ziffernblöcke aus Text extrahieren
15.07.2008 11:37:54
Peter
Hallo Claus,
das könnte (nachdem due deine Bereiche angepasst hast) so gehen:
'
' es sollen nur Ziffern aus den Zellen extrahiert werden
'

Public Sub OnlyDigits()
Dim re      As Object
Dim rCelle  As Range
Set re = CreateObject("vbscript.regexp")
re.Pattern = "[^0-9]+"
re.Global = True
For Each rCelle In Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
Worksheets("Tabelle3").Cells(rCelle.Row, 2).Value = re.Replace(rCelle.Value, "")
Next rCelle
Set re = Nothing
End Sub


Gruß Peter

Anzeige
AW: Ziffernblöcke aus Text extrahieren
15.07.2008 12:04:00
Claus
Hallo Peter,
vielen Dank. Das ist es schon fast. Hier werden jetzt aber alle Ziffern innerhalb einer Zelle ausgeworfen. Ich möchte aber noch mehr, nämlich wenn mehrere Ziffernblöcke in einer Zelle sind, auch mehrere Zellen mit den entsprechenden Zahlen.
Also anstatt: 233559023350 in B1 eben 23; 355; 902335; 0 in Zellen untereinander. Ich fürchte, das ist wesentlich komplizierter. Soll übrigens auch für Spalte A gelten, da kann auch Text drin sein, zufällig in diesem Beispiel sind es nur Zahlen.

AW: Ziffernblöcke aus Text extrahieren
15.07.2008 10:12:31
Tino
Hallo,
hättest du eine Beispielmappe?
Gruß Tino

AW: Ziffernblöcke aus Text extrahieren
15.07.2008 12:25:00
Erich
Hallo Claus,
diese Prozedur schreibt die Ziffernblöcke aus B1:Bnnn in die entsprechenden Zeilen im Blatt "Ziffernblöcke",
allerdings die zu einer Zelle gehörenden Blöcke in einer Zeile in mehrere Spalten:

Sub Ziffernbloecke()
Dim rng As Range, strE As String, intC As Integer, intP As Integer
Dim strZ As String
Worksheets("Daten aus Word").Select
With Worksheets("Ziffernblöcke")
.Cells.ClearContents
.Cells.NumberFormat = "@"
For Each rng In Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
strE = ""
intC = 1
For intP = 1 To Len(rng)
strZ = Mid(rng, intP, 1)
If strZ Like "[0-9]" Then
strE = strE & strZ
ElseIf strE > "" Then
.Cells(rng.Row, intC) = strE
strE = ""
intC = intC + 1
End If
Next intP
If strE > "" Then .Cells(rng.Row, intC) = strE
Next rng
End With
End Sub

Wenn du die einzelnen Ziffernblöcke untereinander schreibst, kannst du nicht mehr erkennen,
welche Blöcke aus welcher Quellzelle stammen.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: Ziffernblöcke aus Text extrahieren
15.07.2008 12:40:00
Claus
Hallo Erich,
vielen Dank erst mal.
Leider komme ich grade nicht zum testen, muss gleich in eine Besprechung, werde es am späten Nachmittag ansehen.
Aber: Mir wäre es untereinander doch lieber, denn ich benötige weniger die Zuordnung zur ursprünglichen Zelle, sondern ich möchte die Zahlen entsprechend filtern und wieder in ein anderes Programm einfügen.
Bonuswunsch: Könnte man aus allen (z steht jetzt für Ziffer, t für text) zzzzzzttz noch zzzzzz00z machen und ausgeben?
Herzliche Grüße
Claus

AW: Ziffernblöcke aus Text extrahieren
15.07.2008 12:40:00
Erich
Hallo Claus,
und hier noch ne Version, die die Spalten A und B verarbeitet und die Bläcke untereinander ausgibt.
Rechts neben jedem Block steht die Quellzelle.

Sub ZiffernbloeckeUntereinander()
Dim rng As Range, strE As String, lngZ As Long, intP As Integer
Dim strZ As String
Worksheets("Daten aus Word").Select
With Worksheets("Ziffernblöcke")
Range(.Columns(1), .Columns(2)).ClearContents
.Columns(1).NumberFormat = "@"
lngZ = 1
For Each rng In Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
strE = ""
For intP = 1 To Len(rng)
strZ = Mid(rng, intP, 1)
If strZ Like "[0-9]" Then
strE = strE & strZ
ElseIf strE > "" Then
.Cells(lngZ, 1) = strE
.Cells(lngZ, 2) = rng.Address(0, 0)
strE = ""
lngZ = lngZ + 1
End If
Next intP
If strE > "" Then
.Cells(lngZ, 1) = strE
.Cells(lngZ, 2) = rng.Address(0, 0)
lngZ = lngZ + 1
End If
Next rng
.Select
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: Ziffernblöcke aus Text extrahieren
15.07.2008 18:27:38
Claus
Boah, toll wie viele gute Versionen ihr da extra für mich produziert. Hoffentlich ist es jetzt nicht unverschämt von mir, das Beste aus verschiedenen Versionen zusammenzuwünschen?
An sich am Klarsten und mein Favorit ist: Version von Erich G. am 15.07.2008 12:40:22
Dazu käme dann noch mein Bonuswunsch: Könnte man aus allen (z steht jetzt für Ziffer, t für text) zzzzzzttz noch zzzzzz00z machen und ausgeben?
Eure Gedanken dazu waren auch o.k.: Ich möchte also tatsächlich zwei Buchstaben (normalerweise "xx", aber wenn jemand "vv" für Version schreibt oder irgendwas anderes gilt das eben auch) durch "00" ersetzt haben, weil per firmeneigener Definition daraus eine ebensolche Gruppe wird. In gewisser Weise ist es natürlich eine Manipulation - eben eine gewollte - und es wäre dann noch das Tüpfelchen auf dem i, wenn dieses "00" z. B. in roter Schrift wäre, damit man zwar damit weiterarbeiten kann, aber immerhin erkennt, dass der Makro entsprechend eingegriffen hat.
Leider durchschaue ich die VB-Codes so wenig, dass ich mir jetzt die entsprechenden Teile nicht mal zusammenstupfen kann. Also wäre echt nett, wenn ihr mir das Ganze jetzt noch fertig bauen könntet.
Liebe Grüße derweil.

Anzeige
AW: Ziffernblöcke aus Text extrahieren
15.07.2008 21:13:30
Erich
Hi Claus,
probier mal (wenig elegant, aber mit RegExp kenne ich mich einfach zu wenig aus...)

Sub ZiffernbloeckeUntereinander2()
Dim rng As Range, strE As String, lngZ As Long, intP As Integer
Dim strZ As String, strW As String
Worksheets("Daten aus Word").Select
With Worksheets("Ziffernblöcke")
Range(.Columns(1), .Columns(2)).ClearContents
.Columns(1).NumberFormat = "@"
lngZ = 1
For Each rng In Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
strW = rng
strE = ""
For intP = 1 To Len(strW)
If intP  "" Then
.Cells(lngZ, 1) = strE
.Cells(lngZ, 2) = rng.Address(0, 0)
strE = ""
lngZ = lngZ + 1
End If
Next intP
If strE > "" Then
.Cells(lngZ, 1) = strE
.Cells(lngZ, 2) = rng.Address(0, 0)
lngZ = lngZ + 1
End If
Next rng
.Select
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: Ziffernblöcke mit Einfärben
16.07.2008 07:24:00
Erich
Hi Claus,
probier mal

Sub ZiffernbloeckeUntereinander3()
Dim rng As Range, strE As String, lngZ As Long, intP As Integer
Dim strZ As String, strW As String
Dim arrI(1 To 10) As Integer, intI As Integer, intJ As Integer
Worksheets("Daten aus Word").Select
With Worksheets("Ziffernblöcke")
Range(.Columns(1), .Columns(2)).ClearContents
With .Columns(1)
.NumberFormat = "@"
.Font.ColorIndex = 0
End With
lngZ = 1
For Each rng In Range("A1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
strW = rng
strE = ""
For intP = 1 To Len(strW)
strZ = Mid(strW, intP, 1)
If intP  " " And _
Not Mid(strW, intP + 1, 1) Like "[0-9]" And _
Mid(strW, intP + 1, 1) = Mid(strW, intP + 2, 1) And _
Mid(strW, intP + 3, 1) Like "[0-9]" Then
strE = strE & strZ & "00" & Mid(strW, intP + 3, 1)
intP = intP + 3
intI = intI + 1
arrI(intI) = Len(strE) - 2
ElseIf strZ Like "[0-9]" Then
strE = strE & strZ
ElseIf strE > "" Then
With .Cells(lngZ, 1)
.Value = strE
For intJ = 1 To intI
.Characters(arrI(intJ), 2).Font.ColorIndex = 3
Next intJ
End With
intI = 0
.Cells(lngZ, 2) = rng.Address(0, 0)
strE = ""
lngZ = lngZ + 1
End If
Next intP
If strE > "" Then
With .Cells(lngZ, 1)
.Value = strE
For intJ = 1 To intI
.Characters(arrI(intJ), 2).Font.ColorIndex = 3
Next intJ
End With
intI = 0
.Cells(lngZ, 2) = rng.Address(0, 0)
lngZ = lngZ + 1
End If
Next rng
.Select
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: noch eine Version
15.07.2008 13:23:38
Erich
Hi Tino,
dein Vorschlag entspricht im Ergebnis etwa dem:

Sub Ziffernbloecke2()
Dim rng As Range, strE As String, lngC As Long, intP As Integer
Dim strZ As String, strW As String
Worksheets("Daten aus Word").Select
With Worksheets("Ziffernblöcke")
.Cells.ClearContents
.Cells.NumberFormat = "@"
For Each rng In Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
strW = rng.Offset(0, -1) & " " & rng
strE = ""
lngC = 1
For intP = 1 To Len(strW)
strZ = Mid(strW, intP, 1)
If strZ Like "[0-9]" Then
strE = strE & strZ
ElseIf strE > "" Then
.Cells(rng.Row, lngC) = strE
strE = ""
lngC = lngC + 1
End If
Next intP
If strE > "" Then .Cells(rng.Row, lngC) = strE
Next rng
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
aber nur fasst ;-)
15.07.2008 13:44:49
Tino
Hallo Erich,
kommt in etwa hin.
Nur meine Version geht davon aus, dass z. Bsp. bei 902335xx0 die Buchstaben xx oder 23-355 der - zur Zahl gehören.
Ich weis gefordert waren nur die Zahlen,
aber ohne diese Zeichen hat mir einfach der Sinn in diesen Zahlen gefehlt!
Ist ja ein Forum und dies war nur ein Vorschlag.
Gruß Tino

www.VBA-Excel.de


eine Version 2; untereinander u. rot
15.07.2008 20:15:00
Tino
Hallo,
die einzelnen Zellen kommen jetzt untereinander und die Zelle in denen eine Änderung gemacht wurde bekommen die Textfarbe rot.
Auf das einfärben der einzelnen Textpassagen habe ich jetzt verzichtet.
https://www.herber.de/bbs/user/53836.xls
Gruß Tino

www.VBA-Excel.de


Anzeige
Einzelzeichen in rot
15.07.2008 22:25:53
Tino
Hallo,
so habe mal noch etwas gebastelt.
Jetzt werden nur die Zeichen rot gefärbt die vom Makro geändert wurden.
Ausgiebige Tests habe ich jetzt nicht gemacht.
https://www.herber.de/bbs/user/53838.xls
Gruß Tino

http://www.VBA-Excel.de


Anzeige
AW: Ziffernblöcke aus Text extrahieren
16.07.2008 09:54:18
Claus
Also ich bin begeistert. Habe soeben beide Versionen kurz geckecked, beide haben funktioniert. Tino hat die Einarbeitung von Textblöcken universeller interpretiert, was manchmal wohl auch benötigt wird, an Erichs Version gefällt mir die Anzeige der Urzelle und schnellere Laufzeit.
Sodele, leider habe ich jetzt keine Zeit für ausführliche Tests, das hole ich aber nach und gebe auf jeden Fall nochmal Bescheid. Ach so, und es gibt ja dieses Sprichwort mit dem kleinen Finger und der ganzen Hand, evtl. kommt also noch ein Bonuswunsch dazu, der sich aber erst formulieren lässt, wenn ich ´ne Weile damit gearbeitet habe. Aber das wäre ja dann schon fast so, als ob ihr Auftragsprogrammierer für mich wärt, ich weiß ja jetzt schon nicht, wie ich mich bedanken soll. Auf jeden Fall kann ich sagen, dass ich mich wirklich sehr freue.
Da ich mich auch nicht für eine der beiden Versionen entscheiden kann und will, werde ich Zwei Schaltflächen einbauen und somit beide Versionen nutzen.
Also, in ein paar Tagen hört ihr nochmals von mir.
Bis dahin liebe Grüße vom begeisterten
Claus

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige