Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Macr variabler gestalten

Betrifft: Macr variabler gestalten von: Thomas
Geschrieben am: 04.07.2015 12:23:26

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

https://www.herber.de/bbs/user/98632.xlsm

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

  

Betrifft: nachgefragt von: AlexG
Geschrieben am: 04.07.2015 14:07:20

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


  

Betrifft: AW: nachgefragt von: Thomas
Geschrieben am: 04.07.2015 14:24:06

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


  

Betrifft: AW: nachgefragt von: Daniel
Geschrieben am: 04.07.2015 14:30:04

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


  

Betrifft: AW: nachgefragt von: Thomas
Geschrieben am: 04.07.2015 15:27:11

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



  

Betrifft: Mit Namenstabelle von: AlexG
Geschrieben am: 04.07.2015 15:17:29

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


  

Betrifft: AW: Macr variabler gestalten von: fcs
Geschrieben am: 04.07.2015 15:33:08

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



  

Betrifft: vielen Dank von: Thomas
Geschrieben am: 04.07.2015 16:19:32

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






https://www.herber.de/bbs/user/98634.xlsm


  

Betrifft: AW: vielen Dank von: Thomas
Geschrieben am: 04.07.2015 18:13:05

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



  

Betrifft: AW: vielen Dank von: AlexG
Geschrieben am: 04.07.2015 18:22:35

Hallo Thomas,

Hier ist jetzt auch die Reihenfolge der Namen egal.

https://www.herber.de/bbs/user/98636.xlsm

Gruß
Alex


  

Betrifft: AW: vielen Dank von: AlexG
Geschrieben am: 04.07.2015 18:31:33

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


  

Betrifft: klasse gelöst von: Thomas
Geschrieben am: 04.07.2015 20:32:48

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


  

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




 

Beiträge aus den Excel-Beispielen zum Thema "Macr variabler gestalten"