Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

von Zeilen in Spalten transformieren nach FETT

von Zeilen in Spalten transformieren nach FETT
27.05.2013 13:46:18
Zeilen
Hallo zusammen
Ich habe eine grosse Excel-Liste welche wie folgt aussieht:
021 244 97 95
Callcenter unbekannt
Postfach 200101
021 317 55 55
Link Marketing
021 334 57 77
Callcenter unbekannt
021 343 24 91
MIS Trend SA, Lausanne
Schweiz
021 508 70 06
Prämien Scout AG, kostenloser Prämienvergleich
Die einzelnen Datensätze beginnen jeweils mit einen Fett markierten Eintrag, dann folgenden 1 - 3 Zeilen von Text welche zum Datensatz gehöhren. Der neue Datensatz beginnt wieder mit einem fetten Eintrag.
Ich müsste nun die Zeilen zwischen den fetten Einträgen in einzelne Spalten kopieren, so dass die Datensätze anschliessend als CSV exportiert werden können.
Leider bin ich ein VBA Anfänger und habe wenig Wissen wie ich dies konkreit in Marco umsetzen kann.
Hat jemand eine Idee?
Danke und Gruss
MTH

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: von Zeilen in Spalten transformieren nach FETT
27.05.2013 14:14:55
Zeilen
Hallo,
in ein Modul und aus der Tabelle starten:
Sub Trans()
Dim rngA As Range, rngB As Range, oTrans As Object
Dim maxCols As Integer, arr, i As Integer, j As Integer, arrtmp, arrDaten
Set oTrans = CreateObject("Scripting.dictionary")
Set rngA = Range("A1")  'Startzelle
Set rngB = rngA
Do
Do
Set rngB = rngB.Offset(1)
Loop Until rngB.Offset(1).Font.Bold Or rngB.Offset(1) = ""
oTrans(oTrans.Count) = WorksheetFunction.Transpose(Range(rngA, rngB))
maxCols = WorksheetFunction.Max(maxCols, Range(rngA, rngB).Rows.Count)
Set rngA = rngB.Offset(1)
Set rngB = rngA
Loop Until rngA = ""
arr = oTrans.items
ReDim arrDaten(1 To oTrans.Count, 1 To maxCols)
For i = 0 To UBound(arr)
arrtmp = arr(i)
For j = LBound(arrtmp) To UBound(arrtmp)
arrDaten(i + 1, j) = arrtmp(j)
Next
Next
Sheets(2).Cells(1, 1).Resize(oTrans.Count, maxCols) = arrDaten
End Sub

Gruß
Rudi

Anzeige
So z.B.
27.05.2013 14:16:50
Jackd
Hallo MTH
Sub fettTrans()
Dim Bereich As Range
Dim Fett As Range
Dim AdresseZeile As Integer
Dim AdresseSpalte As Integer
Dim iVerschieber As Integer
With ActiveSheet.Range("A1:A13")
For Each Fett In ActiveSheet.Range("A1:A13")
If Fett.Font.Bold = True Then
iVerschieber = 0
AdresseZeile = Fett.Row
AdresseSpalte = Fett.Column
Else
iVerschieber = iVerschieber + 1
.Cells(AdresseZeile, AdresseSpalte + iVerschieber).Value = Fett.Value
End If
Next
End With
End Sub
Grüße

319 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige