Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1432to1436
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

Macr variabler gestalten

Macr variabler gestalten
04.07.2015 12:23:26
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

Die Datei https://www.herber.de/bbs/user/98632.xlsm wurde aus Datenschutzgründen gelöscht


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

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
nachgefragt
04.07.2015 14:07:20
AlexG
Hallo Thomas,
stehen in den Spalten zwischen Datum und Artikelnummer bzw. zwischen den Namen immer die gleichen Werte wie hier dargestellt?
ORGINAL

 BCDEFGHIJKLMNOPQRST
4DatumAAArtikelbbbbName2CCCCName3SSSSName4


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

Anzeige
AW: nachgefragt
04.07.2015 14:24:06
Thomas
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

Anzeige
AW: nachgefragt
04.07.2015 14:30:04
Daniel
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

AW: nachgefragt
04.07.2015 15:27:11
Thomas
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

Anzeige
Mit Namenstabelle
04.07.2015 15:17:29
AlexG
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

Anzeige
AW: Macr variabler gestalten
04.07.2015 15:33:08
fcs
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 

Anzeige
vielen Dank
04.07.2015 16:19:32
Thomas
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

Die Datei https://www.herber.de/bbs/user/98634.xlsm wurde aus Datenschutzgründen gelöscht


Anzeige
AW: vielen Dank
04.07.2015 18:13:05
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

Anzeige
AW: vielen Dank
04.07.2015 18:31:33
AlexG
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

Anzeige
klasse gelöst
04.07.2015 20:32:48
Thomas
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

Bitte, gern geschehen Gruß Alex (owT)
04.07.2015 21:16:33
AlexG

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige