Thema Datum  Von Nutzer Rating
Antwort
Rot Tabelle aufteilen in neue Dateien
01.02.2012 16:27:02 Rasti
NotSolved

Ansicht des Beitrags:
Von:
Rasti
Datum:
01.02.2012 16:27:02
Views:
1074
Rating: Antwort:
  Ja
Thema:
Tabelle aufteilen in neue Dateien

 Hallo,

habe folgendes Makro gefunden, dass mir alle gleichen Werte in Spalte A in neue Dateien aufteilt. Meine Frage ist, wie kann ich den Code denn modifizieren, um beispielsweise nach allen 100 Zeilen jedesmal aufzuteilen und ne neue Datei erstellen:

 

Public Sub Aufteilen()
    Dim objDictionary As Object
    Dim objCell As Range, objCopyRange As Range
    Dim objWorkbook As Workbook
    Dim ialngIndex As Long
    Dim avntValues As Variant, avntKeys As Variant
    Dim strFirstAddress As String
    Application.ScreenUpdating = False
    With Tabelle1
        avntValues = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value2
    End With
    Set objDictionary = CreateObject("Scripting.Dictionary")
    For ialngIndex = LBound(avntValues) To UBound(avntValues)
        objDictionary(avntValues(ialngIndex, 1)) = vbNullString
    Next
    avntKeys = objDictionary.Keys
    Set objDictionary = Nothing
    With Tabelle1
        For ialngIndex = LBound(avntKeys) To UBound(avntKeys)
            Set objCell = .Columns(1).Find(What:=avntKeys(ialngIndex), _
                LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
            If Not objCell Is Nothing Then
                strFirstAddress = objCell.Address
                Set objCopyRange = .Cells(1, 1)
                Do
                    Set objCopyRange = Union(objCopyRange, objCell)
                    Set objCell = .Columns(1).FindNext(objCell)
                Loop Until objCell.Address = strFirstAddress
                Set objWorkbook = Workbooks.Add(xlWBATWorksheet)
                objCopyRange.EntireRow.Copy Destination:=objWorkbook.Worksheets(1).Cells(1, 1)
                objWorkbook.Close SaveChanges:=True, Filename:= _
                    ThisWorkbook.Path & "\" & avntKeys(ialngIndex) & ".xls"
                Set objWorkbook = Nothing
                Set objCell = Nothing
                Set objCopyRange = Nothing
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub

 

Thx for help!

 

Gruß Rasti


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst genau und ausführlich
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
  • Bitte markieren Sie Ihre Anfrage als erledigt wenn Ihnen geholfen wurde
Thema: Name: Email:

 
 

Thema Datum  Von Nutzer Rating
Antwort
Rot Tabelle aufteilen in neue Dateien
01.02.2012 16:27:02 Rasti
NotSolved