Thema: Macr variabler gestalten

Hallo Excelgemeinde,
ich habe mit hilfe von WHO ein Macro um eine Tabelle neu zuordnen.
Leider ist die noch ein wenig zu starr. Es bestimmt mit den zeilen Range("b4:E" & lz).Copy Range("b" & lz_einf) die Bereiche welche geordnet werden sollen.
Da sich bei mir aber die Spaltenanzahl ständig verändert wäre es toll wenn jemand das Macro so gestalten könnte das die Bereiche anhand der Begriffe in der Überschrift erkannt wird. Z.B.
1. Bereich ist Datum:Artikel
2. Bereich ist von name2 bis eine Spalte vor Name3
3. Bereich ist von name3 bis eine Spalte vor Name4
4. Bereich ist von name4 bis zur letzten gefüllten Spalte in der Überschrift.
Kann sich dies mal jemand anschauen ob es möglich ist und mir dies dann umschreiben?
vielen dank schon mal für euer interesse
liebe grüsse thomas

Sub test_ordnen_modul_13() lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row ' 'letzte Zeile suchen in Spalte f lz = Cells(Rows.Count, "F").End(xlUp).Row lz_einf = Cells(Rows.Count, "b").End(xlUp).Row + 1 ' letzte gefüllte zeile in Spalte b 'A:C kopieren,Bereich verschieben Range("b4:E" & lz).Copy Range("b" & lz_einf) Range("k4:o" & lz).Cut Range("F" & lz_einf) 'letzte Zeile neu setzen lz_einf = Cells(Rows.Count, "b").End(xlUp).Row + 1 Range("b4:E" & lz).Copy Range("b" & lz_einf) Range("p4:t" & lz).Cut Range("F" & lz_einf) ' letzten bereich an spalte setzen 'Range("C2").CurrentRegion.Interior.ColorIndex = xlNone End Sub

Hallo Thomas,
stehen in den Spalten zwischen Datum und Artikelnummer bzw. zwischen den Namen immer die gleichen Werte wie hier dargestellt?
ORGINAL

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

4

Datum

A

A

Artikel

b

b

b

b

Name2

C

C

C

C

Name3

S

S

S

S

Name4

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
Gruß
Alex

Hallo Alex,
nein leider nicht. Dies ist nur ein beispiel die Grundtabelle hatt ca. 140 verschiedene Spaltenüberschriften.
Aber ich hatte auch schon in die richtung gedacht vieleicht könnte man die Zeile 3 mit wenn dann Formeln
mit gleichen Werten befüllen und sich daran orientieren. Aber dies habe ich auch noch nicht sinnvoll hinbekommen.
Bin auch schon den ganzen Tag auf der suche vieleicht könnte man auch die Spalten in bestimmten zellen angeben und das macro sucht sich in den betroffenen Zellen dann sein Bereich. Jedoch finde ich auch dazu nichts im netz.
Liebe grüsse thomas

Hi
da müsstest du schon mal ein Original-er Überschhriftenspalten hochladen.
man muss ja irgendwie herausfinden, wieviele Spalten ein Namensbereich hat und woran man erkennen kann, wo dieser anfängt und endet.
um das herauszufinden, helfen keine verfläschten Daten.
Gruss Daniel

Hallo,
vielen dank das Ihr versucht mir zu helfen.
Leider verändern sich die Spalteneinträge und auch die Spaltenanzahlen ständig. Sicher ist eigendlich nur das der erste bereich immer von
1. Datum bis Artikel ( dazwischen können mal 4 mal 5 spalten sein)
2. Bereich geht immer von Name2 bis eine Spalte vor Name3 ( dazwischen können zwischen 5 und 10 Spalten sein.
3. Bereich geht immer von Name3 bis eine Spalte vor Name4 ( dazwischen können zwischen 5 und 10 Spalten sein.
4. Bereich ist immer von Name 4 bis 20 Spalten danach sein
Kann man mit den untenstehenden Ansatz was machen? Dies macro markiert die spalten mit den begriffen.
Damit könnte man den jeweiligen anfang des Bereichs finden. wenn man jetzt noch die markierten Spalten adressen auslesen könnte und in eine zelle schreibt hätte man schon irgentwo die bereiche zu stehen (anstatt select )
Ich hoffe ihr lacht mich jtzt nicht aus aber ich habe nicht die ohne Ahnung von VBA.

Sub aac()
Dim rngC As Range, rngT As Range
Dim strS(1 To 6) As String
Dim i As Long
strS(1) = "Datum"
strS(2) = "Name2"
strS(3) = "Name3"
strS(4) = "Name4"
'strS(5) = "Name4"
'strS(6) = "test6"
On Error Resume Next
For i = 1 To UBound(strS)
Set rngT = Rows(4).Find(What:=strS(i), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).EntireColumn
If Not rngT Is Nothing Then
If Not rngC Is Nothing Then
Set rngC = Application.Union(rngC, rngT)
Else
Set rngC = rngT
End If
Set rngT = Nothing
rngC.Select
End If
Next i
End Sub

Hallo Thomas,
das ist jetzt eine Laien Lösung von mir mit einer Hilfsmappe in der die Namen in der Reihenfolge aufgelistet sind wie sie in der Original Tabelle vorkommen.
Was anderes fällt mir bei der Hitze gerade nicht ein

Sub Test_ordnen_Modul()
Dim lz, lz_einf, lngDatR, lngNameZ As Long
Dim intDatS, intArtS As Long
Dim intSpalte1, intSpalte2 As Integer
Dim intLetzteS, intI As Integer
Dim strName As String

lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngDatR = Cells.Find("Datum").Row
intDatS = Cells.Find("Datum").Column
intArtS = Cells.Find("Artikel").Column
intLetzteS = Cells(lngDatR, Columns.Count).End(xlToLeft).Column
lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
lngNameZ = 2
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
Application.ScreenUpdating = False
intSpalte1 = intArtS + 1
intI = 0
Do While strName <> ""
    Do While Sheets("Test").Cells(lngDatR, intSpalte1 + intIl) <> strName
        intI = intI + 1
        intSpalte2 = intSpalte1 + intI
    Loop
    If strName <> Sheets("Namen").Cells(2, 1).Value Then
        Sheets("Test").Range(Cells(lngDatR, intDatS), Cells(lz, intArtS)).Copy _
        Sheets("Test").Range(Cells(lz_einf, intDatS), Cells(lz_einf, intDatS))
        Sheets("Test").Range(Cells(lngDatR, intSpalte1), Cells(lz, intSpalte2)).Cut _
        Sheets("Test").Range(Cells(lz_einf, intArtS + 1), Cells(lz_einf, intArtS + 1))
        'letzte Zeile neu setzen 
        lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
        'Anfangsspalte zum Ausschneiden neu setzen 
        intSpalte1 = intSpalte2 + 1
        'neuen Namen setzten 
        lngNameZ = lngNameZ + 1
        strName = Sheets("Namen").Cells(lngNameZ, 1).Value
    Else
        'Anfangsspalte zum Ausschneiden neu setzen 
        intSpalte1 = intSpalte2 + 1
        'neuen Namen setzten 
        lngNameZ = lngNameZ + 1
        strName = Sheets("Namen").Cells(lngNameZ, 1).Value
    End If
Loop
Range(Cells(1, intDatS), Cells(1, intLetzteS)).Columns.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Hier noch die Datei
https://www.herber.de/bbs/user/98633.xlsm
Gruß
Alex

Hallo Thomas,
hier dein Makro variabler gestaltet
Gruß
Franz

Sub test_ordnen_modul_13()
Dim wks As Worksheet
Dim lz As Long, lz_einf As Long
Dim intName As Integer
Dim spaDatum, spaArtikel, spaName, spaL
Const Zeile_1 = 4 'Zeile mit Überschriften
Set wks = ActiveSheet
With wks
spaDatum = fncSpalte(varWert:="Datum", rngBereich:=.Rows(Zeile_1))
If spaDatum = 0 Then GoTo Beenden
lz = .UsedRange.SpecialCells(xlCellTypeLastCell).Row  '
'letzte Zeile suchen in Spalte "Datum"
lz = .Cells(.Rows.Count, spaDatum).End(xlUp).Row
If lz <= Zeile_1 Then
MsgBox "keine Daten vorhanden"
GoTo Beenden
End If
spaArtikel = fncSpalte(varWert:="Artikel", rngBereich:=.Rows(Zeile_1))
If spaArtikel = 0 Then GoTo Beenden
For intName = 2 To 4
spaName = fncSpalte(varWert:="Name" & Format(intName, "0"), rngBereich:=.Rows( _
Zeile_1))
If spaName = 0 Then GoTo Beenden
If intName = 4 Then
spaL = .Cells(Zeile_1, .Columns.Count).End(xlToLeft).Column
Else
spaL = fncSpalte(varWert:="Name" & Format(intName + 1, "0"), rngBereich:=.Rows( _
Zeile_1)) - 1
End If
If spaL = 0 Then GoTo Beenden
' letzte gefüllte Zeile in Spalte "Datum"
lz_einf = .Cells(.Rows.Count, spaDatum).End(xlUp).Row + 1
'Datum:Artikel kopieren,Bereich ohne Spaltentitel
.Range(.Cells(Zeile_1 + 1, spaDatum), .Cells(lz, spaArtikel)).Copy _
wks.Cells(lz_einf, spaDatum)
'NameX bis letzte Spalte kopieren ohne Spaltentitel
.Range(.Cells(Zeile_1 + 1, spaName), .Cells(lz, spaL)).Copy _
wks.Cells(lz_einf, spaArtikel + 1)
Next
lz_einf = .Cells(.Rows.Count, spaDatum).End(xlUp).Row
'Daten im Quellbereich der umgruppierten Daten löschen
spaName = fncSpalte(varWert:="Name2", rngBereich:=.Rows(Zeile_1))
.Range(.Cells(Zeile_1, spaName), .Cells(lz, spaL)).Delete shift:=xlShiftToLeft
'Zellfüllungen löschen
'.Cells(Zeile_1, spaDatum).CurrentRegion.Interior.ColorIndex = xlNone
End With
Beenden:
Set wks = Nothing
End Sub
Function fncSpalte(varWert, rngBereich As Range) As Long
Dim spa
spa = Application.Match(varWert, rngBereich, 0)
If IsError(spa) Then
MsgBox "Spalte mit """ & varWert & """ in Titelzeile nicht gefunden", _
vbOKOnly, "Suche Spalte"
fncSpalte = 0
Else
fncSpalte = spa
End If
End Function

Hallo,
vielen dank an AlexG
Ich finde beide Lösungen klasse. Alex kannst Du noch mal schauen in meiner ersten tabelle war leider das im Blatt orginal noch der Name2, Name3, und Name4 falsch gesetzt so das dein Macro nicht richtig funktionieren kann sorry ich hoffe Du kannst mein Mist wieder geradebiegen. Denn ich würde gern auch deine Idee Nutzen.
Hallo Franz,
auch dir lieben lieben dank für dein macro dies funktioniert auch total gut. In diesem Fall finde ich es aber besser wenn ich die Bereichstrennung im extrablatt definieren könnte. Dann hätte ich es leichter wenn ich die Tabelle mal an aderer Stelle trennen muss. ( Anderer Überschriftsname.
Könnt Ihr beide trotz der temp noch mal schauen? Bitte bitte.
liebe Grüsse thomas

Hallo Alex,
ich glaube ich habe schon ein Sonnenstich es ist ja egal ob ich nun den Bereichsanfang oder den Bereichsende angebe. Jedoch in der untenstehenden Version ist noch ein kleiner fehler.
Es wird aus dem zweiten Bereich eine Spalte zu viel nach unten kopiert. bestimmt muss ich nur irgenteine Zahl verändern leider finde ich nicht welche.
Kannst Du noch mal schauen?
liebe grüsse Thomas

Sub Test_ordnen_Modul()
Dim lz, lz_einf, lngDatR, lngNameZ As Long
Dim intDatS, intArtS As Long
Dim intSpalte1, intSpalte2 As Integer
Dim intLetzteS, intI As Integer
Dim strName As String
lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngDatR = Cells.Find("Datum").Row
intDatS = Cells.Find("Datum").Column
intArtS = Cells.Find("Artikel").Column
intLetzteS = Cells(lngDatR, Columns.Count).End(xlToLeft).Column
lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
lngNameZ = 2
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
Application.ScreenUpdating = False
intSpalte1 = intArtS + 1
intI = 0
Do While strName <> ""
Do While Sheets("Test").Cells(lngDatR, intSpalte1 + intI) <> strName
intI = intI + 1
intSpalte2 = intSpalte1 + intI
Loop
If strName <> Sheets("Namen").Cells(2, 1).Value Then
Sheets("Test").Range(Cells(lngDatR, intDatS), Cells(lz, intArtS)).Copy _
Sheets("Test").Range(Cells(lz_einf, intDatS), Cells(lz_einf, intDatS))
Sheets("Test").Range(Cells(lngDatR, intSpalte1), Cells(lz, intSpalte2)).Cut _
Sheets("Test").Range(Cells(lz_einf, intArtS + 1), Cells(lz_einf, intArtS + 1))
'letzte Zeile neu setzen
lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
'Anfangsspalte zum Ausschneiden neu setzen
intSpalte1 = intSpalte2 + 1
'neuen Namen setzten
lngNameZ = lngNameZ + 1
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
Else
'Anfangsspalte zum Ausschneiden neu setzen
intSpalte1 = intSpalte2 + 1
'neuen Namen setzten
lngNameZ = lngNameZ + 1
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
End If
Loop
Range(Cells(1, intDatS), Cells(1, intLetzteS)).Columns.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Hallo Thomas,
Hier ist jetzt auch die Reihenfolge der Namen egal.
https://www.herber.de/bbs/user/98636.xlsm
Gruß
Alex

Hallo Thomas,
noch eine kleine Korrektur, ich hatte mit der falschen letzten Zeile bei den Namen gearbeitet.

Option Explicit

Sub Test_ordnen_Modul()
Dim lz, lz_einf, lngDatR, intLetzteZNamen As Long
Dim intDatS, intArtS, intRang As Integer
Dim intSpalte1, intSpalte2 As Integer
Dim intLetzteS, intI, intMaxRang As Integer

lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngDatR = Sheets("Test").Cells.Find("Datum").Row
intDatS = Sheets("Test").Cells.Find("Datum").Column
intArtS = Sheets("Test").Cells.Find("Artikel").Column
intLetzteS = Sheets("Test").Cells(lngDatR, Columns.Count).End(xlToLeft).Column
intLetzteZNamen = Sheets("Namen").Cells(lngDatR, Columns.Count).End(xlToLeft).Row
lz_einf = Sheets("Test").Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
intRang = 2
intMaxRang = Application.WorksheetFunction.Max(Sheets("Namen").Range("C:C"))

Application.ScreenUpdating = False
For intI = 2 To intLetzteZNamen
    If Sheets("Namen").Cells(intI, 3).Value = intRang Then
        intSpalte1 = Sheets("Namen").Cells(intI, 2).Value
    End If
Next intI
If intRang <= intMaxRang Then
    For intI = 2 To intLetzteZNamen
        If Sheets("Namen").Cells(intI, 3).Value = intRang + 1 Then
            intSpalte2 = Sheets("Namen").Cells(intI, 2).Value - 1
        End If
    Next intI
Else: intSpalte2 = intLetzteS
End If


Do While intRang <= intMaxRang
        Sheets("Test").Range(Cells(lngDatR, intDatS), Cells(lz, intArtS)).Copy _
        Sheets("Test").Range(Cells(lz_einf, intDatS), Cells(lz_einf, intDatS))
        Sheets("Test").Range(Cells(lngDatR, intSpalte1), Cells(lz, intSpalte2)).Cut _
        Sheets("Test").Range(Cells(lz_einf, intArtS + 1), Cells(lz_einf, intArtS + 1))
        'letzte Zeile neu setzen 
        lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
        'Anfangsspalte zum Ausschneiden neu setzen 
        intSpalte1 = intSpalte2 + 1
        intRang = intRang + 1
        If intRang < intMaxRang Then
            For intI = 2 To lz
                If Sheets("Namen").Cells(intI, 3).Value = intRang Then
                    intSpalte2 = Sheets("Namen").Cells(intI, 2).Value
                End If
            Next intI
        Else: intSpalte2 = intLetzteS
        End If
Loop
Range(Cells(1, intDatS), Cells(1, intLetzteS)).Columns.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Gruß
Alex

Hallo Alex,
dies ist ja super, es klappt bestens.
Damit kann ich viele andere probleme mit lösen. Du hast mir sehr geholfen.
liebe grüsse Thomas

Hallo Excelgemeinde,
ich habe mit hilfe von WHO ein Macro um eine Tabelle neu zuordnen.
Leider ist die noch ein wenig zu starr. Es bestimmt mit den zeilen Range("b4:E" & lz).Copy Range("b" & lz_einf) die Bereiche welche geordnet werden sollen.
Da sich bei mir aber die Spaltenanzahl ständig verändert wäre es toll wenn jemand das Macro so gestalten könnte das die Bereiche anhand der Begriffe in der Überschrift erkannt wird. Z.B.
1. Bereich ist Datum:Artikel
2. Bereich ist von name2 bis eine Spalte vor Name3
3. Bereich ist von name3 bis eine Spalte vor Name4
4. Bereich ist von name4 bis zur letzten gefüllten Spalte in der Überschrift.
Kann sich dies mal jemand anschauen ob es möglich ist und mir dies dann umschreiben?
vielen dank schon mal für euer interesse
liebe grüsse thomas

Sub test_ordnen_modul_13() lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row ' 'letzte Zeile suchen in Spalte f lz = Cells(Rows.Count, "F").End(xlUp).Row lz_einf = Cells(Rows.Count, "b").End(xlUp).Row + 1 ' letzte gefüllte zeile in Spalte b 'A:C kopieren,Bereich verschieben Range("b4:E" & lz).Copy Range("b" & lz_einf) Range("k4:o" & lz).Cut Range("F" & lz_einf) 'letzte Zeile neu setzen lz_einf = Cells(Rows.Count, "b").End(xlUp).Row + 1 Range("b4:E" & lz).Copy Range("b" & lz_einf) Range("p4:t" & lz).Cut Range("F" & lz_einf) ' letzten bereich an spalte setzen 'Range("C2").CurrentRegion.Interior.ColorIndex = xlNone End Sub

Hallo Thomas,
stehen in den Spalten zwischen Datum und Artikelnummer bzw. zwischen den Namen immer die gleichen Werte wie hier dargestellt?
ORGINAL

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

4

Datum

A

A

Artikel

b

b

b

b

Name2

C

C

C

C

Name3

S

S

S

S

Name4

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
Gruß
Alex

Hallo Alex,
nein leider nicht. Dies ist nur ein beispiel die Grundtabelle hatt ca. 140 verschiedene Spaltenüberschriften.
Aber ich hatte auch schon in die richtung gedacht vieleicht könnte man die Zeile 3 mit wenn dann Formeln
mit gleichen Werten befüllen und sich daran orientieren. Aber dies habe ich auch noch nicht sinnvoll hinbekommen.
Bin auch schon den ganzen Tag auf der suche vieleicht könnte man auch die Spalten in bestimmten zellen angeben und das macro sucht sich in den betroffenen Zellen dann sein Bereich. Jedoch finde ich auch dazu nichts im netz.
Liebe grüsse thomas

Hi
da müsstest du schon mal ein Original-er Überschhriftenspalten hochladen.
man muss ja irgendwie herausfinden, wieviele Spalten ein Namensbereich hat und woran man erkennen kann, wo dieser anfängt und endet.
um das herauszufinden, helfen keine verfläschten Daten.
Gruss Daniel

Hallo,
vielen dank das Ihr versucht mir zu helfen.
Leider verändern sich die Spalteneinträge und auch die Spaltenanzahlen ständig. Sicher ist eigendlich nur das der erste bereich immer von
1. Datum bis Artikel ( dazwischen können mal 4 mal 5 spalten sein)
2. Bereich geht immer von Name2 bis eine Spalte vor Name3 ( dazwischen können zwischen 5 und 10 Spalten sein.
3. Bereich geht immer von Name3 bis eine Spalte vor Name4 ( dazwischen können zwischen 5 und 10 Spalten sein.
4. Bereich ist immer von Name 4 bis 20 Spalten danach sein
Kann man mit den untenstehenden Ansatz was machen? Dies macro markiert die spalten mit den begriffen.
Damit könnte man den jeweiligen anfang des Bereichs finden. wenn man jetzt noch die markierten Spalten adressen auslesen könnte und in eine zelle schreibt hätte man schon irgentwo die bereiche zu stehen (anstatt select )
Ich hoffe ihr lacht mich jtzt nicht aus aber ich habe nicht die ohne Ahnung von VBA.

Sub aac()
Dim rngC As Range, rngT As Range
Dim strS(1 To 6) As String
Dim i As Long
strS(1) = "Datum"
strS(2) = "Name2"
strS(3) = "Name3"
strS(4) = "Name4"
'strS(5) = "Name4"
'strS(6) = "test6"
On Error Resume Next
For i = 1 To UBound(strS)
Set rngT = Rows(4).Find(What:=strS(i), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False).EntireColumn
If Not rngT Is Nothing Then
If Not rngC Is Nothing Then
Set rngC = Application.Union(rngC, rngT)
Else
Set rngC = rngT
End If
Set rngT = Nothing
rngC.Select
End If
Next i
End Sub

Hallo Thomas,
das ist jetzt eine Laien Lösung von mir mit einer Hilfsmappe in der die Namen in der Reihenfolge aufgelistet sind wie sie in der Original Tabelle vorkommen.
Was anderes fällt mir bei der Hitze gerade nicht ein

Sub Test_ordnen_Modul()
Dim lz, lz_einf, lngDatR, lngNameZ As Long
Dim intDatS, intArtS As Long
Dim intSpalte1, intSpalte2 As Integer
Dim intLetzteS, intI As Integer
Dim strName As String

lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngDatR = Cells.Find("Datum").Row
intDatS = Cells.Find("Datum").Column
intArtS = Cells.Find("Artikel").Column
intLetzteS = Cells(lngDatR, Columns.Count).End(xlToLeft).Column
lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
lngNameZ = 2
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
Application.ScreenUpdating = False
intSpalte1 = intArtS + 1
intI = 0
Do While strName <> ""
    Do While Sheets("Test").Cells(lngDatR, intSpalte1 + intIl) <> strName
        intI = intI + 1
        intSpalte2 = intSpalte1 + intI
    Loop
    If strName <> Sheets("Namen").Cells(2, 1).Value Then
        Sheets("Test").Range(Cells(lngDatR, intDatS), Cells(lz, intArtS)).Copy _
        Sheets("Test").Range(Cells(lz_einf, intDatS), Cells(lz_einf, intDatS))
        Sheets("Test").Range(Cells(lngDatR, intSpalte1), Cells(lz, intSpalte2)).Cut _
        Sheets("Test").Range(Cells(lz_einf, intArtS + 1), Cells(lz_einf, intArtS + 1))
        'letzte Zeile neu setzen 
        lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
        'Anfangsspalte zum Ausschneiden neu setzen 
        intSpalte1 = intSpalte2 + 1
        'neuen Namen setzten 
        lngNameZ = lngNameZ + 1
        strName = Sheets("Namen").Cells(lngNameZ, 1).Value
    Else
        'Anfangsspalte zum Ausschneiden neu setzen 
        intSpalte1 = intSpalte2 + 1
        'neuen Namen setzten 
        lngNameZ = lngNameZ + 1
        strName = Sheets("Namen").Cells(lngNameZ, 1).Value
    End If
Loop
Range(Cells(1, intDatS), Cells(1, intLetzteS)).Columns.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Hier noch die Datei
https://www.herber.de/bbs/user/98633.xlsm
Gruß
Alex

Hallo Thomas,
hier dein Makro variabler gestaltet
Gruß
Franz

Sub test_ordnen_modul_13()
Dim wks As Worksheet
Dim lz As Long, lz_einf As Long
Dim intName As Integer
Dim spaDatum, spaArtikel, spaName, spaL
Const Zeile_1 = 4 'Zeile mit Überschriften
Set wks = ActiveSheet
With wks
spaDatum = fncSpalte(varWert:="Datum", rngBereich:=.Rows(Zeile_1))
If spaDatum = 0 Then GoTo Beenden
lz = .UsedRange.SpecialCells(xlCellTypeLastCell).Row  '
'letzte Zeile suchen in Spalte "Datum"
lz = .Cells(.Rows.Count, spaDatum).End(xlUp).Row
If lz <= Zeile_1 Then
MsgBox "keine Daten vorhanden"
GoTo Beenden
End If
spaArtikel = fncSpalte(varWert:="Artikel", rngBereich:=.Rows(Zeile_1))
If spaArtikel = 0 Then GoTo Beenden
For intName = 2 To 4
spaName = fncSpalte(varWert:="Name" & Format(intName, "0"), rngBereich:=.Rows( _
Zeile_1))
If spaName = 0 Then GoTo Beenden
If intName = 4 Then
spaL = .Cells(Zeile_1, .Columns.Count).End(xlToLeft).Column
Else
spaL = fncSpalte(varWert:="Name" & Format(intName + 1, "0"), rngBereich:=.Rows( _
Zeile_1)) - 1
End If
If spaL = 0 Then GoTo Beenden
' letzte gefüllte Zeile in Spalte "Datum"
lz_einf = .Cells(.Rows.Count, spaDatum).End(xlUp).Row + 1
'Datum:Artikel kopieren,Bereich ohne Spaltentitel
.Range(.Cells(Zeile_1 + 1, spaDatum), .Cells(lz, spaArtikel)).Copy _
wks.Cells(lz_einf, spaDatum)
'NameX bis letzte Spalte kopieren ohne Spaltentitel
.Range(.Cells(Zeile_1 + 1, spaName), .Cells(lz, spaL)).Copy _
wks.Cells(lz_einf, spaArtikel + 1)
Next
lz_einf = .Cells(.Rows.Count, spaDatum).End(xlUp).Row
'Daten im Quellbereich der umgruppierten Daten löschen
spaName = fncSpalte(varWert:="Name2", rngBereich:=.Rows(Zeile_1))
.Range(.Cells(Zeile_1, spaName), .Cells(lz, spaL)).Delete shift:=xlShiftToLeft
'Zellfüllungen löschen
'.Cells(Zeile_1, spaDatum).CurrentRegion.Interior.ColorIndex = xlNone
End With
Beenden:
Set wks = Nothing
End Sub
Function fncSpalte(varWert, rngBereich As Range) As Long
Dim spa
spa = Application.Match(varWert, rngBereich, 0)
If IsError(spa) Then
MsgBox "Spalte mit """ & varWert & """ in Titelzeile nicht gefunden", _
vbOKOnly, "Suche Spalte"
fncSpalte = 0
Else
fncSpalte = spa
End If
End Function

Hallo,
vielen dank an AlexG
Ich finde beide Lösungen klasse. Alex kannst Du noch mal schauen in meiner ersten tabelle war leider das im Blatt orginal noch der Name2, Name3, und Name4 falsch gesetzt so das dein Macro nicht richtig funktionieren kann sorry ich hoffe Du kannst mein Mist wieder geradebiegen. Denn ich würde gern auch deine Idee Nutzen.
Hallo Franz,
auch dir lieben lieben dank für dein macro dies funktioniert auch total gut. In diesem Fall finde ich es aber besser wenn ich die Bereichstrennung im extrablatt definieren könnte. Dann hätte ich es leichter wenn ich die Tabelle mal an aderer Stelle trennen muss. ( Anderer Überschriftsname.
Könnt Ihr beide trotz der temp noch mal schauen? Bitte bitte.
liebe Grüsse thomas

Hallo Alex,
ich glaube ich habe schon ein Sonnenstich es ist ja egal ob ich nun den Bereichsanfang oder den Bereichsende angebe. Jedoch in der untenstehenden Version ist noch ein kleiner fehler.
Es wird aus dem zweiten Bereich eine Spalte zu viel nach unten kopiert. bestimmt muss ich nur irgenteine Zahl verändern leider finde ich nicht welche.
Kannst Du noch mal schauen?
liebe grüsse Thomas

Sub Test_ordnen_Modul()
Dim lz, lz_einf, lngDatR, lngNameZ As Long
Dim intDatS, intArtS As Long
Dim intSpalte1, intSpalte2 As Integer
Dim intLetzteS, intI As Integer
Dim strName As String
lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngDatR = Cells.Find("Datum").Row
intDatS = Cells.Find("Datum").Column
intArtS = Cells.Find("Artikel").Column
intLetzteS = Cells(lngDatR, Columns.Count).End(xlToLeft).Column
lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
lngNameZ = 2
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
Application.ScreenUpdating = False
intSpalte1 = intArtS + 1
intI = 0
Do While strName <> ""
Do While Sheets("Test").Cells(lngDatR, intSpalte1 + intI) <> strName
intI = intI + 1
intSpalte2 = intSpalte1 + intI
Loop
If strName <> Sheets("Namen").Cells(2, 1).Value Then
Sheets("Test").Range(Cells(lngDatR, intDatS), Cells(lz, intArtS)).Copy _
Sheets("Test").Range(Cells(lz_einf, intDatS), Cells(lz_einf, intDatS))
Sheets("Test").Range(Cells(lngDatR, intSpalte1), Cells(lz, intSpalte2)).Cut _
Sheets("Test").Range(Cells(lz_einf, intArtS + 1), Cells(lz_einf, intArtS + 1))
'letzte Zeile neu setzen
lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
'Anfangsspalte zum Ausschneiden neu setzen
intSpalte1 = intSpalte2 + 1
'neuen Namen setzten
lngNameZ = lngNameZ + 1
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
Else
'Anfangsspalte zum Ausschneiden neu setzen
intSpalte1 = intSpalte2 + 1
'neuen Namen setzten
lngNameZ = lngNameZ + 1
strName = Sheets("Namen").Cells(lngNameZ, 1).Value
End If
Loop
Range(Cells(1, intDatS), Cells(1, intLetzteS)).Columns.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Hallo Thomas,
Hier ist jetzt auch die Reihenfolge der Namen egal.
https://www.herber.de/bbs/user/98636.xlsm
Gruß
Alex

Hallo Thomas,
noch eine kleine Korrektur, ich hatte mit der falschen letzten Zeile bei den Namen gearbeitet.

Option Explicit

Sub Test_ordnen_Modul()
Dim lz, lz_einf, lngDatR, intLetzteZNamen As Long
Dim intDatS, intArtS, intRang As Integer
Dim intSpalte1, intSpalte2 As Integer
Dim intLetzteS, intI, intMaxRang As Integer

lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
lngDatR = Sheets("Test").Cells.Find("Datum").Row
intDatS = Sheets("Test").Cells.Find("Datum").Column
intArtS = Sheets("Test").Cells.Find("Artikel").Column
intLetzteS = Sheets("Test").Cells(lngDatR, Columns.Count).End(xlToLeft).Column
intLetzteZNamen = Sheets("Namen").Cells(lngDatR, Columns.Count).End(xlToLeft).Row
lz_einf = Sheets("Test").Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
intRang = 2
intMaxRang = Application.WorksheetFunction.Max(Sheets("Namen").Range("C:C"))

Application.ScreenUpdating = False
For intI = 2 To intLetzteZNamen
    If Sheets("Namen").Cells(intI, 3).Value = intRang Then
        intSpalte1 = Sheets("Namen").Cells(intI, 2).Value
    End If
Next intI
If intRang <= intMaxRang Then
    For intI = 2 To intLetzteZNamen
        If Sheets("Namen").Cells(intI, 3).Value = intRang + 1 Then
            intSpalte2 = Sheets("Namen").Cells(intI, 2).Value - 1
        End If
    Next intI
Else: intSpalte2 = intLetzteS
End If


Do While intRang <= intMaxRang
        Sheets("Test").Range(Cells(lngDatR, intDatS), Cells(lz, intArtS)).Copy _
        Sheets("Test").Range(Cells(lz_einf, intDatS), Cells(lz_einf, intDatS))
        Sheets("Test").Range(Cells(lngDatR, intSpalte1), Cells(lz, intSpalte2)).Cut _
        Sheets("Test").Range(Cells(lz_einf, intArtS + 1), Cells(lz_einf, intArtS + 1))
        'letzte Zeile neu setzen 
        lz_einf = Cells(Rows.Count, intDatS).End(xlUp).Offset(1, 0).Row
        'Anfangsspalte zum Ausschneiden neu setzen 
        intSpalte1 = intSpalte2 + 1
        intRang = intRang + 1
        If intRang < intMaxRang Then
            For intI = 2 To lz
                If Sheets("Namen").Cells(intI, 3).Value = intRang Then
                    intSpalte2 = Sheets("Namen").Cells(intI, 2).Value
                End If
            Next intI
        Else: intSpalte2 = intLetzteS
        End If
Loop
Range(Cells(1, intDatS), Cells(1, intLetzteS)).Columns.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub

Gruß
Alex

Hallo Alex,
dies ist ja super, es klappt bestens.
Damit kann ich viele andere probleme mit lösen. Du hast mir sehr geholfen.
liebe grüsse Thomas