Microsoft Excel

Herbers Excel/VBA-Archiv

sichtbare Zeilen aus Tabelle (Strg + t) kopieren


Betrifft: sichtbare Zeilen aus Tabelle (Strg + t) kopieren von: Chrostiffer
Geschrieben am: 17.08.2016 13:25:46

Hallo Zusammen,

ich habe ein weiteres Problem und hoffe auf eure Unterstützung. (die letzten beiden Male hat es sehr gut geklappt!Großes Lob)

Ich habe eine lange (dynamische in Zeilen zwischen 2.000-80.000 Zeilen) Rohdatentabelle ("Export"), Spalten A:M).
Diese würde ich gerne als Tabelle (Strg + T) umwandeln (soll im Nachhinhein auch genutzt werden inkl. Filterfunktion).

Aus dieser "Tabelle 5" möchte ich die ersten 15 sichtbaren Zeilen bestimmter spalten kopieren und in eine vorgefertigte Übersichtsblatt kopieren.
Gefiltert wird eine Spalte (groß nach klein), diese wird im Anschluss ausgeblendet und dann eine weitere Spalte gefiltert. (1.Umsatz dieses Jahr, 2.Umsatz letztes Jahr, 3.Umsatz 2. jahre)

Bisher habe ich es nicht wirklich hinbekommen, nur die ersten 15 Zeilen direkt in die vorgefertigte Maske zu kopieren und habe mir mit einem Behelfsblatt geholfen von dem ich dann die ersten 15 Zeilen markiert habe.

Teilcode für diese Prozedur:

Dim wksLaender As Worksheet
    Dim Zeile As Long
    Dim x As Long
    Dim wksExport As Worksheet
    Set wksExport = ActiveWorkbook.Worksheets("Export")

'Tabelle vorbereiten
   
  
    wksExport.Select
    wksExport.Range("A:A,E:E,G:G,H:H,I:I,K:K,N:N,O:O,P:P,Q:Q,R:R,V:V,W:W,X:X,Y:Y,Z:Z,AA:AA,AB: _
AB,AC:AC").Delete Shift:=xlToLeft
    
    Columns("A:A").Cut
    Columns("N:N").Insert Shift:=xlToRight
    Columns("E:E").Cut
    Columns("N:N").Insert Shift:=xlToRight
    
    wksExport.ListObjects.Add(xlSrcRange, Range("A1:M" & _
             ActiveSheet.UsedRange.Rows.Count), , xlYes).name = _
            "Tabelle5"
    wksExport.ListObjects("Tabelle5").Sort.SortFields. _
            Clear
   
    wksExport.Range("O1").Formula = "=SUBTOTAL(109,F2:F100000)" 'Sales CY
    wksExport.Range("P1").Formula = "=SUBTOTAL(109,G2:G100000)" 'Sales 1Y
    wksExport.Range("Q1").Formula = "=SUBTOTAL(109,H2:H100000)" 'Sales 2Y
    wksExport.Range("R1").Formula = "=SUBTOTAL(109,I2:I100000)" 'Budget 1Y
    wksExport.Range("S1").Formula = "=SUBTOTAL(109,J2:J100000)" 'Budget CY
    wksExport.Range("T1").Formula = "=SUBTOTAL(109,K2:K100000)" 'Budget NY
    wksExport.Range("U1").Formula = "=SUBTOTAL(109,E2:E100000)" 'Potential
' Kann man hier auch das Tabellenende nehmen?
' Es sollte halt ab Zeile 2 beginnen, da Zeile 1 Ja überschrift ist

Nun wird eine Schleife aktiviert, die je nach land ein eigenes Tabellenblatt erstellt und nun Daten aus "Tabelle 5" abgreift.
Info: "Sales_Customer_land" ist das vorgefertigte Übersichtsblatt
Sub SchleifeDatenLand2(strLand As String, strLandName As String, strLandKurz As String)
    Dim wksExport As Worksheet
    Dim wksLand As Worksheet
    Dim wksNeu As Worksheet
    Dim LandCode As Range
    Set wksExport = ActiveWorkbook.Worksheets("Export")
    Dim rngScr As Range
    Set rngScr = Sheets("Export").Range("O1")
    
'Sortierung zurücksetzen und alle daten anzeigen
    With wksExport.ListObjects("Tabelle5")
        .Sort.SortFields.Clear
        If .AutoFilter.FilterMode = True Then
            .AutoFilter.ShowAllData
        End If
    End With

'Prüfen, ob Gefilterte Daten vorhanden sind
    With wksExport
      Set LandCode = .Columns(12).Find(What:=strLand, LookIn:=xlValues, lookat:=xlWhole)
    End With
      If LandCode Is Nothing Then
            GoTo NextLand
        End If
    
'Schleife
   
    Sheets("Sales_Customer_Ranking").Copy After:=Sheets(1)
    Set wksLand = Sheets("Sales_Customer_Ranking (2)")
    wksLand.name = strLandKurz
        
    Worksheets("Export").ListObjects("Tabelle5").Range.AutoFilter Field:=12, _
        Criteria1:=strLand

'THIS YEAR
        
    wksExport.Activate
    wksExport.ListObjects("Tabelle5").Sort.SortFields. _
        Add Key:=Range("Tabelle5[[#All],[SALES_CY]]"), SortOn:=xlSortOnValues, _
        Order:=xlDescending, DataOption:=xlSortNormal
    
    With wksExport.ListObjects("Tabelle5").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Set wksNeu = Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count))
    wksNeu.name = "NeuesBlatt"
    wksExport.Range("A2:F100000").SpecialCells(xlCellTypeVisible).Copy wksNeu.Range("A1")
    wksExport.Range("J2:K100000").SpecialCells(xlCellTypeVisible).Copy wksNeu.Range("G1")
    wksNeu.Range("A1:F15").Copy
    wksLand.Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    wksNeu.Range("G1:H15").Copy
    wksLand.Range("I9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
    With wksLand
        .Select
        .Range("J2").NumberFormat = "DD.MM.YYYY"
        .Range("J2").Value = Date
        .Range("C3") = Sheets("Export").Range("M2")
        .Range("C4") = strLandName
        .Range("G25") = rngScr.Value
        .Range("F25") = rngScr.Offset(0, 6).Value
        .Range("I25") = rngScr.Offset(0, 4).Value
        .Range("J25") = rngScr.Offset(0, 5).Value
        
        End With
    
    wksExport.Columns("F:F").EntireColumn.Hidden = True
    
'LAST YEAR
    wksExport.Activate
    wksExport.ListObjects("Tabelle5").Sort.SortFields. _
        Clear
    wksExport.ListObjects("Tabelle5").Sort.SortFields. _
        Add Key:=Range("Tabelle5[[#All],[SALES_1Y]]"), SortOn:=xlSortOnValues, _
        Order:=xlDescending, DataOption:=xlSortNormal
    With wksExport.ListObjects("Tabelle5").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    wksExport.Range("A2:G100000").SpecialCells(xlCellTypeVisible).Copy wksNeu.Range("A1")
    wksExport.Range("I2:I100000").SpecialCells(xlCellTypeVisible).Copy wksNeu.Range("G1")
    
    wksNeu.Range("A1:G15").Copy
    wksLand.Range("B28").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    
    With wksLand
        .Select
        .Range("G44") = rngScr.Offset(0, 1).Value
        .Range("H44") = rngScr.Offset(0, 3).Value
        .Range("F44") = rngScr.Offset(0, 6).Value
    End With
    wksExport.Columns("G:G").EntireColumn.Hidden = True

'TWO YEARS AGO

    wksExport.ListObjects("Tabelle5").Sort.SortFields. _
        Clear
    wksExport.ListObjects("Tabelle5").Sort.SortFields. _
        Add Key:=Range("Tabelle5[[#All],[SALES_2Y]]"), SortOn:=xlSortOnValues, _
        Order:=xlDescending, DataOption:=xlSortNormal
    With wksExport.ListObjects("Tabelle5").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    wksExport.Range("A1:H100000").SpecialCells(xlCellTypeVisible).Copy wksNeu.Range("A1")
    wksNeu.Range("A1:F15").Copy
    wksLand.Range("B47").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
     wksNeu.Delete
       With wksLand
        .Select
        .Range("F63") = rngScr.Offset(0, 6).Value
        .Range("G63") = rngScr.Offset(0, 2).Value
    End With
   
    wksExport.Cells.EntireColumn.Hidden = False
    
      
NextLand:
    End Sub
Gibt es die Möglichkeit, diesen Code so zu verkürzen/umzubauen, dass ich mir das Behelfsblatt sparen kann und direkt in wksLand kopieren kann?

  

Betrifft: AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren von: Daniel
Geschrieben am: 17.08.2016 13:36:07

Hi

hier ein Codebeispiel, wie du die ersten 15 sichtbaren Zeilen ermittelst und davon bestimmte Spalten kopierst:

dim Zelle as Long
dim KopierZeilen as Range

'--- die ersten 15 sichtbaren Zeilen ermitteln
For each Zelle in Columns(1).SpecialCells(xlcelltypevisible)
    if KopierZeilen is Nothing then
         set Kopierzeilen = Zelle
    else
         set KopierZeilen = Union(Zelle, KopierZeilen)
    end if
    if not KopierZeilen is nothing then If KopierZeilen.Cells.Count >= 15 then Exit For
Next
'--- bestimmte Spalten dieser Zeilen kopieren
Intersect(KopierZeilen.EntrieRow, Range("A:M").Copy
Gruß Daniel


  

Betrifft: AW: Buchstabendreher von: Werner
Geschrieben am: 17.08.2016 13:58:05

Hallo Daniel,

da sind wohl die Finger durcheinander gekommen. ;-D

Intersect(KopierZeilen.EntireRow, Range("A:M").Copy
Gruß Werner


  

Betrifft: AW: Buchstabendreher von: Daniel
Geschrieben am: 17.08.2016 14:04:55

ist ja wurscht, wer versucht das gezeigte zu verstehen und dann selber programmiert, nutzt sowieso die IntelliSense und hat damit dann kein Problem.
Wer einfach nur kopiert und einfügt, ohne sich Gedanken zum machen, darf auch über ein paar Tippfehler stolpern.
Gruß Daniel


  

Betrifft: AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren von: Chrostiffer
Geschrieben am: 18.08.2016 09:45:59

Hallo Daniel,

vielen Dank für deinen Code. Natürlich versuche ich, so gut es geht, diesen zu verstehen und nicht nur copy paste zu machen.
Musste Dim Zelle as Object machen, da sonst ein Fehler aufgetreten ist.
Nach etwas rumprobieren und austesten habe ich es nun soweit hinbekommen, dass er mit nach der Neufilterung der Tabelle (erst Ausblendung einer Spalte und dann nach neue Reihenfolge die richtigen Werte in die richtigen zeilen kopiert.
Soweit also vielen vielen Dank! Es funktioniert.

Leider habe ich noch ein (wahrscheinlich kleines) Problem:

Ich kann/möchte nicht die erste Zeile mitkopieren, da diese ja die Überschrift ist. Also möchte ich ab Zeile 2 die ersten 15 Zeilen kopieren (nur bestimmte Spalten).
Hab es leider nicht hinbekommen.

Grüße Christopher


  

Betrifft: AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren von: Chrostiffer
Geschrieben am: 18.08.2016 12:39:25

Hallo Daniel,

vielen Dank für deinen Code. Natürlich versuche ich, so gut es geht, diesen zu verstehen und nicht nur copy paste zu machen.
Musste Dim Zelle as Object machen, da sonst ein Fehler aufgetreten ist.
Nach etwas rumprobieren und austesten habe ich es nun soweit hinbekommen, dass er mit nach der Neufilterung der Tabelle (erst Ausblendung einer Spalte und dann nach neue Reihenfolge die richtigen Werte in die richtigen zeilen kopiert.
Soweit also vielen vielen Dank! Es funktioniert.

Leider habe ich noch ein (wahrscheinlich kleines) Problem:

Ich kann/möchte nicht die erste Zeile mitkopieren, da diese ja die Überschrift ist. Also möchte ich ab Zeile 2 die ersten 15 Zeilen kopieren (nur bestimmte Spalten).
Hab es leider nicht hinbekommen.

Grüße Christopher

ps: Hatte das Häkchen vergessen


  

Betrifft: AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren von: Daniel
Geschrieben am: 18.08.2016 12:46:55

Hi

wenn du die erste Zeile nicht mit kopieren willst, dann so:

For each Zelle in Range("A2:A" & Cells(Rows.count, 1).end(xlup).row).SpecialCells( _
xlcelltypevisible)

oder so
For each Zelle in activesheet.usedrange.offset(1, 0).resize(activesheet.usedrange.Rows.count -  _
1, 1).specialCells(xlcelltypevisible)
oder auch so (das zusätzliche END IF bitte nicht vergessen)
For each Zelle in Columns(1).SpecialCells(xlcelltypevisible)
    If Zelle.Row > 1 then
        if KopierZeilen is Nothing then



die spalten die kopiert werden, werden hier festgelegt. das Beschreibst du über die Zelladressen der Spalten in der Range-Funktion (Range("A:M"))
Intersect(KopierZeilen.EntrieRow, Range("A:M").Copy
Gruß Daniel


  

Betrifft: AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren von: Chrostiffer
Geschrieben am: 22.08.2016 11:55:58

Hallo Daniel,

vielen Dank für deine Rückmeldung. Habe es nun wie folgt hinbekommen.
Rows count bis 16, und dann bei Intersect rows.count eingefügt.
Es funkioniert, ob es der richtige Weg ist kann ich nicht sagen. :-D

     For Each Zelle In Columns(1).SpecialCells(xlCellTypeVisible)
         If KopierZeilen Is Nothing Then
              Set KopierZeilen = Zelle
         Else
              Set KopierZeilen = Union(Zelle, KopierZeilen)
         End If
         If Not KopierZeilen Is Nothing Then If KopierZeilen.Cells.Count >= 16 Then Exit  _
For
     Next
    
    
     Intersect(KopierZeilen.EntireRow, Range("A2:F" & Cells(Rows.Count, 1).End(xlUp).Row)). _
Copy
     wksLand.Range("B9").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
           :=False, Transpose:=False
Andere Frage: Ich habe von einem meiner anderen Makros folgenden Speichervorgang übernommen und angepasst. Beim anderen Makro funktioniert alles Problemlos, im "Speichern unter" Dialog wird ein vorgefertigter Speichername angezeigt.
Hier leider nicht.

Irgendwelche Ideen?
    Dim datum As String
    Dim segment As String
    Dim name As String
    Dim varRetVal As Variant
    Dim Datname As String
    Dim sPfad As String


    sPfad = VBA.Environ("USERPROFILE") & "\Documents\Unterlagen\Reports\Budget 2017"
    If Dir(sPfad, vbDirectory) = "" Then
        VBA.MkDir Path:=sPfad
    End If
    sPfad = sPfad & Application.PathSeparator
    With ActiveWorkbook.Worksheets(1)
        datum = Format(Date, "yyyy-mm-dd")
        name = .Range("B1")
        segment = .Range("C3")
    End With
    Datname = datum & "_" & segment & "_" & name
    varRetVal = Application.GetSaveAsFilename( _
      InitialFileName:=sPfad & Datname, _
      FileFilter:="Microsoft Excel-Dateien (*.xlsx), *.xlsx", _
      Title:="save as... ")
    If varRetVal = False Then Exit Sub
    ActiveWorkbook.SaveAs varRetVal, FileFormat:= _
     xlOpenXMLWorkbook



Beiträge aus den Excel-Beispielen zum Thema "sichtbare Zeilen aus Tabelle (Strg + t) kopieren"