Anzeige
Archiv - Navigation
1176to1180
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

Datensätze auf Tabellenblätter verteilen

Datensätze auf Tabellenblätter verteilen
Jockel
Hallo,
ich habe in einer Excelmappe durch ein Makro Daten in eine Excelmappe gepumpt. Die Tabelle heißt "TEMP". Dieses Tabellenblatt beinhaltet praktisch alle meine Daten, beginnen ab Zeile 3 und betrifft die Spalten A - I.
Weiter habe ich ein zweites Tabellenblatt mit Name "Vorlage" in meiner Mappe.
Ich möchte nun folgendes erreichen:
In meinem Tabellenblatt "TEMP", wo alle Daten drin stehen, hat jeder Datensatz in der Spalte A ein Kürzel drin, zB:
A_______B_______C_______D_______E_______F_______G_______H_______I_____
AS______124_____1254____125_____5698____2587____263_____4578____4587__
AS______12554___1254____12544___1245____1254____458____2365____1254__
GT______1245____6543____12547___521_____1236____258____259_____1254___
HB______654_____214_____147______214____4125____4521___2587____1254___
AS______124____1458_____4875_____2155___1254____1269___1452____12547__
GT______1254___1256_____1236_____1254___4875____5874___8574_____8457__
usw.
Wichtig dabei, die Kürzel in der Spalte A können bei jedem Import anders heissen, sind also nie gleich.
Ich möchte nun per Makro alle Datensätze, die in der Spalte A das gleiche Kürzel haben, auf verschiedenen Tabellenblätter aufteilen. Also alle DS mit "AS" in der Spalte A sollen in ein Tabellenblatt, alle DS mit "GT" sollen in ein tabellenblatt usw.
Dazu soll das Blatt "Vorlage" dienen. Ich habe mir das so vorgestellt:
zB alle DS mit "AS" herausfiltern, von der Vorlage eine Kopie machen, die gefilterten Daten in das neue Tabellenblatt schreiben (ab Zeile3) und den vorhandenen Blattname "Vorlage" um "AS" erweitern (Nachher "VORLAGE AS") und dann unter diesem neuen Name abspeichern.
Dann die zweite Gruppe mit "GT" herausfiltern, von der Vorlage eine Kopie machen,die gefilterten Daten in das neue Tabellenblatt schreiben (ab Zeile3) und den vorhandenen Blattname "Vorlage" um "GT" erweitern (Nachher "VORLAGE GT") und dann unter diesem neuen Name abspeichern.
usw.
und das so lange, bis man alle Datensätze gruppiert hat.
Das große Problem dabei: ich weiß nie, wieviel Datensätze ich gesamt habe, und ich weiß nie, welche Kürzel und in welcher Anzahl kommen.
Kann man das irgend wie per Makro automatisieren ? Wäre mir eine große Hilfe. Vielleicht kann ja jemand weiter helfen, wie ich die daten gruppieren kann.
Danke mal
Joachim

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Datensätze auf Tabellenblätter verteilen
20.09.2010 18:49:54
ransi
HAllo Joachim
Versuch mal sowas:
Option Explicit


Public Sub test()
Dim objDic As Object
Dim rng As Range
Dim L As Long
Dim k As Range
Dim arr As Variant
Set rng = Sheets("Temp").Range("A1").CurrentRegion
Set objDic = CreateObject("Scripting.Dictionary")
For L = 1 To rng.Rows.Count
    Set objDic(rng(L, 1).Value) = make_Sure_workSheet_Exists("Vorlage " & Cells(L, 1))
    With objDic(rng(L, 1).Value)
        Set k = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        arr = WorksheetFunction.Transpose(rng.Rows(L).Value)
        k.Resize(, UBound(arr)) = WorksheetFunction.Transpose(arr)
    End With
Next
End Sub


Public Function make_Sure_workSheet_Exists(strText As String) As Worksheet
On Error Resume Next
Set make_Sure_workSheet_Exists = Worksheets(strText)
If Err > 0 Then
    Err.Clear
    Sheets("Vorlage").Copy , Sheets(Sheets.Count)
    Set make_Sure_workSheet_Exists = Sheets(Sheets.Count)
    make_Sure_workSheet_Exists.Name = strText
End If
End Function


Das Blatt mit den Daten heisst Temp, und das Blatt Vorlage hast du ja sowieso...
ransi
Anzeige
ganz kleine Korrektur:
20.09.2010 19:02:36
ransi
HAllo
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Public Sub test()
Dim objDic As Object
Dim rng As Range
Dim L As Long
Dim k As Range
Dim arr As Variant
Set rng = Sheets("Temp").Range("A1").CurrentRegion
Set objDic = CreateObject("Scripting.Dictionary")
For L = 1 To rng.Rows.Count
    Set objDic(rng(L, 1).Value) = make_Sure_workSheet_Exists("Vorlage " & rng(L, 1))
    With objDic(rng(L, 1).Value)
        Set k = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
        arr = WorksheetFunction.Transpose(rng.Rows(L).Value)
        k.Resize(, UBound(arr)) = WorksheetFunction.Transpose(arr)
    End With
Next
End Sub



Public Function make_Sure_workSheet_Exists(strText As String) As Worksheet
On Error Resume Next
Set make_Sure_workSheet_Exists = Worksheets(strText)
If Err > 0 Then
    Err.Clear
    Sheets("Vorlage").Copy , Sheets(Sheets.Count)
    Set make_Sure_workSheet_Exists = Sheets(Sheets.Count)
    make_Sure_workSheet_Exists.Name = strText
End If
End Function


ransi
Anzeige
AW: ganz kleine Korrektur
20.09.2010 21:11:13
Jockel
Hallo ransi,
werds morgen testen. melde mich wieder.
Gruss
Joachim
AW: ganz kleine Korrektur:
21.09.2010 08:13:18
Jockel
Hallo ransi,
das funktioniert soweit sehr gut, Vielen, vielen Dank, ist echt klasse :-)
zwei Kleinigkeiten:
- was muss ich ändern, dass die Daten, wenn sie in die einzelnen Tabellenblätter geschrieben werden, nicht schon in der Zeile2, sondern erst ab Zeile 3 beginnen sollen. Ich möchte zwischen Überschrift und Daten eine Leerzeile.
- Kannst du noch ein paar Wörter Kommentar dazu schreiben, dass ich den Code auch verstehe :-))
Sonst vielen Dank
Joachim
AW: ganz kleine Korrektur:
21.09.2010 22:12:03
ransi
HAllo Jockel
Mit dem Dictionary war ich ganz weit über das Ziel hinausgeschossen.
Durch die Function make_sure_workSheet_Exists() ist das Dictionary so nützlich wie ein drittes ´Nasenloch.
Der Check ob das Blatt schon vorhanden ist macht ja die Function.
Schau mal ob das jetzt verstehst:
Option Explicit




Public Sub test()
Dim rng As Range
Dim L As Long
Dim k As Range
Dim arr As Variant
Dim WS As Worksheet
Set rng = Sheets("Temp").Range("A1").CurrentRegion
For L = 1 To rng.Rows.Count
    Set WS = make_Sure_workSheet_Exists("Vorlage " & rng(L, 1))
    With WS
        Set k = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Erste Freie Zelle in WS.Range("A:A")
        If k.Row = 2 Then Set k = k.Offset(1, 0)
        arr = WorksheetFunction.Transpose(rng.Rows(L).Value)
        k.Resize(, UBound(arr)) = WorksheetFunction.Transpose(arr)
    End With
Next
End Sub




Public Function make_Sure_workSheet_Exists(strText As String) As Worksheet
On Error Resume Next
Set make_Sure_workSheet_Exists = Worksheets(strText)
'Function läuft in einen Fehler wenn es das
'Sheet(strText) nicht gibt.
'Dann wird das Blatt"Vorlage" kopiert und umbenannt.
If Err > 0 Then
    Err.Clear
    Sheets("Vorlage").Copy , Sheets(Sheets.Count)
    Set make_Sure_workSheet_Exists = Sheets(Sheets.Count)
    make_Sure_workSheet_Exists.Name = strText
End If
End Function


ransi
Anzeige

123 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige