Tabelle1 auf x-Tabellen verteilen

Guten Morgen,
im habe im Archiv gesucht und fand keinen Artikel der mein Problem löst.
Jeden Tag bekomme ich von unserem System eine CSV-Tabelle die ich in vorbereitetes Excel-Sheet einfüge.
In der Tabelle1 vom Excel-Sheet sind dann ca 500 Datensätze die ich auf verschiedene Tabellen verteilen muss.
In der Spalte C stehen die Werte verschiedene Werte ( ca 20 ) wie BD01, AX15, ZW51, etc.
Nun möchte ich das Excel folgendes macht.
Erster Datensatz lesen, eine neue Tabelle im Sheet anlegen (sofern nicht schon vorhanden) mit dem Namen aus Spalte C, den entsprechenden Datensatz kopieren und in der neuen, oder bestehenden Tabelle ab Spalte 2 einfügen.
Nett wäre natürlich noch, wenn beim anlegen der neuen Tabelle, die Titel-Zeile aus Tabelle1 übernommen würde.
Danke für Hilfe.
Dave

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
kannst mal den Code testen, im Code evtl. die Tabelle noch anpassen (hier aus Bsp. Tabelle1)


Option Explicit

Sub Test()
Dim oDic As Object, ArrayC, varValue
Dim rngBereich As Range, oWS As Worksheet, rngCrit As Range

'Tabelle anpassen 
With Sheets("Tabelle1")
    Set rngBereich = .Range("A1", .Cells(.Rows.Count, 3).End(xlUp).Offset(0, 13))
    If Intersect(rngBereich, .Rows(2)) Is Nothing Then Exit Sub 'keine Daten 
    ArrayC = .Range("C2", .Cells(.Rows.Count, 3).End(xlUp))
    Set rngCrit = .Cells(1, .Columns.Count).Resize(2)
End With

Set oDic = CreateObject("Scripting.Dictionary")
For Each varValue In ArrayC
   If varValue <> "" Then oDic(varValue) = 0
Next varValue
ArrayC = oDic.keys

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    
    With rngBereich
        For Each varValue In ArrayC
            Set oWS = CheckTab(CStr(varValue))
            If Not oWS Is Nothing Then
                rngCrit.Cells(2, 1).FormulaR1C1 = "=RC3=""" & varValue & """"
    
                .AdvancedFilter xlFilterCopy, rngCrit, oWS.Range("A1").Resize(, .Columns.Count)
            End If
        Next varValue
    End With
    
     rngCrit.EntireColumn.Delete
     
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

Function CheckTab(strName$) As Worksheet
Dim nIndex%
On Error Resume Next
With ThisWorkbook
    nIndex = .Sheets(strName).Index
    If nIndex = 0 Then
        With .Sheets.Add(After:=.Sheets(.Sheets.Count))
            .Name = strName
            Set CheckTab = .Sheets
        End With
        Set CheckTab = .Sheets(.Sheets.Count)
    Else
        Set CheckTab = .Sheets(nIndex)
    End If
End With
End Function

Gruß Tino

Sub aaaa() Dim wks As Worksheet, lRow As Long With Sheets("Tabelle1") Application.ScreenUpdating = False For lRow = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Set wks = Nothing On Error Resume Next Set wks = Worksheets(.Cells(lRow, 3).Value) On Error GoTo 0 If wks Is Nothing Then Set wks = Worksheets.Add(after:=Sheets(Sheets.Count)) wks.Name = .Cells(lRow, 3) .Range("A1:P1").Copy wks.Cells(1, 1) End If .Range(.Cells(lRow, 1), .Cells(lRow, 16)).Copy _ wks.Cells(Rows.Count, 1).End(xlUp).Offset(1) Next End With End Sub

Sub aaaa() Dim wks As Worksheet, lRow As Long With Sheets("Tabelle1") Application.ScreenUpdating = False For lRow = 2 To .Cells(Rows.Count, 1).End(xlUp).Row Set wks = Nothing On Error Resume Next Set wks = Worksheets(CStr(.Cells(lRow, 3).Value)) On Error GoTo 0 If wks Is Nothing Then Set wks = Worksheets.Add(after:=Sheets(Sheets.Count)) wks.Name = .Cells(lRow, 3).Value .Range("A1:P1").Copy wks.Cells(1, 1) End If .Range(.Cells(lRow, 1), .Cells(lRow, 16)).Copy _ wks.Cells(Rows.Count, 1).End(xlUp).Offset(1) Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Tabelle1 auf x-Tabellen verteilen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread