Anzeige
Archiv - Navigation
1168to1172
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
Inhaltsverzeichnis

VBA-Makro

VBA-Makro
Horst
Hallo Excel-Freaks,
folgendes Makro liest beginnend mit Zeile A4 jeweils Werte der Spalte A ("Datum", "Heure", "Quantité" und "Prix") aus den Bereich "B:Y" aus, transponiert diese und kopiert sie untereinander:
Option Explicit
Dim Regex As Object
Function FindDateInString(strString$) As Date
Dim objMatch As Object, oDate As Date
If Regex Is Nothing Then
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.MultiLine = True
.Pattern = "\d+[-]\d+[-]\d+"
.Global = True
End With
End If
Set objMatch = Regex.Execute(strString$)
If objMatch.Count > 0 Then
oDate = DateValue(objMatch(0))
End If
FindDateInString = oDate
End Function

Sub Copy_Transpose_Range()
Dim rngTitel As Range, rngDaten As Range, rngTmp As Range
Dim lngAbstand As Long
Dim meARDate(), nCount
With Sheets("Daten")
Set rngTitel = .Range("A4:A6")
Set rngTmp = .Columns(1).Find(What:="Heure", LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
If Not rngTmp Is Nothing Then
Set rngDaten = rngTmp.Offset(0, 1).Resize(3, 24)
nCount = nCount + 1
ReDim Preserve meARDate(1 To nCount)
meARDate(nCount) = FindDateInString(rngTmp.Offset(-2, 0).Text)
Set rngTmp = .Columns(1).FindNext(rngTmp)
Do While rngTmp.Address  rngTitel(1).Address
nCount = nCount + 1
ReDim Preserve meARDate(1 To nCount)
meARDate(nCount) = FindDateInString(rngTmp.Offset(-2, 0).Text)
Set rngDaten = Union(rngDaten, rngTmp.Offset(0, 1).Resize(3, 24))
Set rngTmp = .Columns(1).FindNext(rngTmp)
Loop
End If
End With
nCount = 1
If Not rngDaten Is Nothing Then
With Sheets.Add(After:=Sheets(Sheets.Count))
.Range("A1") = "Datum"
.Range("B1:D1") = Application.Transpose(rngTitel)
.Rows(1).Font.Bold = True
For Each rngTmp In rngDaten.Areas
With .Range("A2").Offset(lngAbstand, 0)
.Offset(0, 1).Resize(24, 3).Value = Application.Transpose(rngTmp)
.Resize(24, 1) = meARDate(nCount)
.Resize(24, 1).NumberFormat = "m/d/yyyy"
End With
nCount = nCount + 1
lngAbstand = lngAbstand + rngTmp.Columns.Count
Next rngTmp
.UsedRange.EntireColumn.AutoFit
End With
End If
Set Regex = Nothing
End Sub

Wie muss die VBA-Prozedur verändert werden, dass zusätzlich noch die in der jeweils ersten Zeile stehende Textfolge "Allemagne-France" bzw. "France-Allemagne" ausgegeben wird. Optimalerweise sollten sich zwei unterschiedliche Tabellen erstellen. Eine mit den transponierten Werten von "Allemagne-France" und eine mit den Werten für "France-Allemagne".
https://www.herber.de/bbs/user/70960.xls
Besten Dank vorab!
Horst

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: VBA-Makro
12.08.2010 22:09:29
Horst
Besten Dank Franz!
Die VBA-Prozedur funktioniert großartig!!
Spitzenleistung!!
Gruß Horst
PS: Hast du auch eine Mailadresse, falls ich mal Fragen zu komplexeren VBA-Projekten habe (gerne auch gegen Bezahlung)?
AW: VBA-Makro
13.08.2010 00:15:44
fcs
Hallo Horst,
mein Mailaddresse findest du hier unter Forumsseiten--Profile--Profilliste.
Gruß
Franz

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige