Anzeige
Archiv - Navigation
1508to1512
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

sichtbare Zeilen aus Tabelle (Strg + t) kopieren

sichtbare Zeilen aus Tabelle (Strg + t) kopieren
17.08.2016 13:25:46
Chrostiffer
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?

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren
17.08.2016 13:36:07
Daniel
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
Anzeige
AW: Buchstabendreher
17.08.2016 13:58:05
Werner
Hallo Daniel,
da sind wohl die Finger durcheinander gekommen. ;-D
Intersect(KopierZeilen.EntireRow, Range("A:M").Copy
Gruß Werner
AW: Buchstabendreher
17.08.2016 14:04:55
Daniel
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
AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren
18.08.2016 09:45:59
Chrostiffer
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
Anzeige
AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren
18.08.2016 12:39:25
Chrostiffer
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
Anzeige
AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren
18.08.2016 12:46:55
Daniel
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
Anzeige
AW: sichtbare Zeilen aus Tabelle (Strg + t) kopieren
22.08.2016 11:55:58
Chrostiffer
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

Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige