VBA-Makro
Horst
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