Everything Divide Column A!

All same values from sheet "Master" column A are distributed on worksheets. The worksheets are provided. With repetitive call of the code the provided worksheets are deleted and again provided. The example works with 6000 (29 different) values and autofilters. The column A is not sorted. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1".


Alle gleichen Werte aus Tabellenblatt "Master" Spalte A sollen auf Tabellenblätter verteilt werden. Die Tabellenblätter werden erstellt. Bei wiederholtem Aufruf des Codes werden die erstellten Tabellenblätter gelöscht und neu erstellt. Das Beispiel arbeitet mit 6000 (29 unterschiedlichen) Werten und Autofilter. Die Spalte A ist nicht sortiert. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1".


Option Explicit
Public Sub Everything_Divide()
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim rngRange As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wksSheet = ThisWorkbook.Worksheets("Master")
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "ID*" Then
wksTMP.Delete
End If
Next wksTMP
Set wksTMP = Worksheets.Add
wksSheet.UsedRange.Copy wksTMP.Range("A1")
With wksTMP
Set rngRange = .Range("A1").CurrentRegion
rngRange.Sort Key1:=.Range("A2"), _
Order1:=xlAscending, Header:=xlYes
lngRow = 2
Do Until IsEmpty(rngRange.Cells(lngRow, 1))
If rngRange.Cells(lngRow, 1) <> _
rngRange.Cells(lngRow - 1, 1) Then
rngRange.AutoFilter field:=1, _
Criteria1:=rngRange.Cells(lngRow, 1)
Set rngTMP = rngRange.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move _
After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ID_" & rngRange.Cells(lngRow, 1)
rngTMP.Copy Range("A1")
End If
lngRow = lngRow + 1
Loop
End With
Fin:
If Not wksTMP Is Nothing Then wksTMP.Delete
Application.Goto Reference:=wksSheet.Cells(1, 1), Scroll:=True
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
If Not wksSheet Is Nothing Then wksSheet.AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...