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

VBA Datum

VBA Datum
27.01.2016 10:51:58
Fabian
Hallo zusammen,
ich habe in einer Liste Daten für 2 Tage, die ich nach Datum sortiere.
Im nächsten Schritt möchte ich, dass die Daten von Tag 1 in eine neue Tabelle kopiert werden. Zusätzlich, sollen die erste 20% von Tag 2 ebenfalls in die neue Tabelle kopiert werden.
Finde allerdings nicht die richtige Formel(n) dafür.
Vielen Dank für eure Hilfe.

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Datum
27.01.2016 13:35:22
UweD
Hallo Fabian
so ?

Option Explicit
Sub Fabian()
On Error GoTo Fehler
Dim TB1 As Worksheet, TB2 As Worksheet
Dim ANZ%, ZE%, SP&, LR&, Proz!, AB2&
Dim Datum1 As Date, Datum2 As Date
ZE = 1 'Überschrift bis Zeile; 0= ohne
SP = 1 'Spalte A
Proz = 0.2 '20%
Set TB1 = ActiveSheet
With TB1
LR = .Cells(Rows.Count, SP).End(xlUp).Row 'letzte Zeile der Spalte
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Cells(1, SP), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range(Cells(1, SP), Cells(LR, SP))
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Datum1 = .Cells(ZE + 1, SP)
ANZ = WorksheetFunction.CountIf(Columns(SP), Datum1)
AB2 = ANZ + ZE + 1
Sheets.Add After:=Sheets(Sheets.Count)
Set TB2 = ActiveSheet
TB2.Name = Datum1
.Rows(ZE + 1 & ":" & AB2 - 1).Copy TB2.Rows(ZE + 1)
Datum2 = .Cells(AB2, SP)
'20% ermitteln = mind 1
ANZ = WorksheetFunction.Max(1, Int(WorksheetFunction.CountIf(.Columns(SP), Datum2) *  _
Proz))
Sheets.Add After:=Sheets(Sheets.Count)
Set TB2 = ActiveSheet
TB2.Name = Datum2
.Rows(AB2 & ":" & ANZ + AB2 - 1).Copy TB2.Rows(ZE + 1)
End With
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Gruß UweD
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige