Macro to Tabulate 100k Data into Individual Sheets

**leeaw** · 08-29-2012, 03:17 AM

Hi,

I need to copy/move data from the main database to individual sheets based on the number of assets.

My number of assets can ranged from 1-1000.
Is it possible to automate the creation of sheets based on the number of assets?

The file is too big. But my rows = 102k, columns from A - V.

**arlu1201** · 08-29-2012, 10:08 AM

Should the sheets be created based on the asset_ID? Should the sheet be named the same as the asset_id?

**leeaw** · 08-29-2012, 09:19 PM

The sheets can be named according to asset id but the sheets must consist of the same total number of assets.

Means i need to consolidate all the same number of assets into one sheet. (eg. 1 asset into 1 sheet, 100 assets into 1 sheet)
if there are more than 1 person who have 1 asset then should be consolidated into 1 sheet.

I have this macro but it can only hold 30 arguements.And i have to manually create 1000 sheets.
shDest = WorksheetFunction.Choose(AllCells.Rows.Count , "2 Assets", "3 Assets", "4 Assets", "5 Assets")

Sub abc()
Const shMain As String = "Main"
Dim shDest As String
Dim AllCells As Range, Cell As Range
Dim UniqueValues As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item
Dim Lastrow As Long, DestLastRow As Long
    
    Worksheets(shMain).AutoFilterMode = False
'   Find lastrow on Column E
    Lastrow = Worksheets(shMain).Cells(Rows.CountLarge, 1).End(xlUp).Row
'   Get items are in Column E
    Set AllCells = Worksheets(shMain).Range("E2:E" & Lastrow)
'   The next statement ignores the error caused
'   by attempting to add a duplicate key to the collection.
'   The duplicate is not added - which is just what we want!
    On Error Resume Next
    For Each Cell In AllCells
        UniqueValues.Add Cell.Value, CStr(Cell.Value)
'       Note: the 2nd argument (key) for the Add method must be a string
    Next Cell
'   Resume normal error handling
    On Error GoTo 0

'   Sort the collection (optional)
    For i = 1 To UniqueValues.Count - 1
        For j = i + 1 To UniqueValues.Count
            If UniqueValues(i) > UniqueValues(j) Then
                Swap1 = UniqueValues(i)
                Swap2 = UniqueValues(j)
                UniqueValues.Add Swap1, before:=j
                UniqueValues.Add Swap2, before:=i
                UniqueValues.Remove i + 1
                UniqueValues.Remove j + 1
            End If
        Next j
    Next i
    
Application.ScreenUpdating = False
For Each Item In UniqueValues
    With Worksheets(shMain)
        .Range("$A$1:$V$" & Lastrow).AutoFilter Field:=4, Criteria1:=CStr(Item)
    Set AllCells = .Range("$A$2:$V$" & Lastrow).SpecialCells(xlCellTypeVisible)
    End With
    shDest = WorksheetFunction.Choose(AllCells.Rows.Count , "2 Assets", "3 Assets", "4 Assets", "5 Assets")
    With Worksheets(shDest)
        AllCells.Copy .Range("a" & .Cells(Rows.CountLarge, "A").End(xlUp).Row + 1)
    End With
Next
Worksheets(shMain).AutoFilterMode = False
Application.ScreenUpdating = True

Set AllCells = Nothing
Set Cell = Nothing
End Sub

**Cutter** · 08-29-2012, 10:39 PM

@ leeaw

Please notice that code tags have been added to your post(s). The forum rules require them so please keep that in mind and add them yourself whenever showing code in any of your future posts. To see instructions for applying them, click on the Forum Rules button at top of the page and read Rule #3.
Thanks.

**jindon** · 08-29-2012, 11:27 PM

Try this


Option Explicit

Sub test()
    Dim e, rng As Range, flg As Boolean, LastR As Range
    Set rng = Sheets("main").Range("a1").CurrentRegion
    With CreateObject("Scripting.Dictionary")
        .Comparemode = 1
        For Each e In rng.Offset(1).Columns(2).Value
            If (e <> "") * (Not .exists(e)) Then
                If Not IsSheetExists(e) Then
                    flg = True
                    Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
                End If
                With Sheets(e)
                    If flg Then
                        Set LastR = .Cells(1)
                    Else
                        Set LastR = .Range("a" & .Rows.Count).End(xlUp)(2)
                    End If
                End With
                rng.AutoFilter 2, e
                rng.Offset(IIf(flg, 0, 1)).Copy LastR
                rng.AutoFilter
                flg = False
            End If
        Next
    End With
End Sub

Function IsSheetExists(ByVal sn As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(sn).Name)
End Function

**leeaw** · 08-30-2012, 01:23 AM

Hi Jindon,

I have used the macro. But it does not move the number of assets to the correct sheets. But rather it actually shifted the assets to different sheets based on the project id.

The sheets should be based on the numbers of assets i have. (eg. Sheet 1 should comprise of all 1 asset, sheet 2 (2 assets) ... )

eg. In the data Andrew has 3 assets based on the S/NO. Peter has 2 assets based on the S/NO.

1. Notebook Andrew
2. PC Andrew
3. Scanner Andrew
1. PC Peter
2. Notebook Peter
1. PDA Jackson
2. PDA Jackson
3. IPAD Jackson
4. IPhone Jackson

**jindon** · 08-30-2012, 01:36 AM

Do you mean like this?

Otherwise I need a workbook with your desired result.


Sub test()
    Dim e, rng As Range, flg As Boolean, LastR As Range
    Set rng = Sheets("main").Range("a1").CurrentRegion
    With CreateObject("Scripting.Dictionary")
        .Comparemode = 1
        For Each e In rng.Offset(1).Columns(4).Value
            If e <> "" Then .Item(e) = .Item(e) + 1
        Next
        For Each e In .keys
            If Not IsSheetExists(.Item(e) & " Assets") Then
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = .Item(e) & " Assets"
                flg = True
            End If
            With Sheets(.Item(e) & " Assets")
                If flg Then
                    Set LastR = .Cells(1)
                Else
                    Set LastR = .Range("a" & Rows.Count).End(xlUp)(2)
                End If
            End With
            rng.AutoFilter 4, e
            rng.Offset(IIf(flg, 0, 1)).Copy LastR
            rng.AutoFilter
            flg = False
        Next
    End With
End Sub

Function IsSheetExists(ByVal sn As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(sn).Name)
End Function

**leeaw** · 08-30-2012, 05:42 AM

sorry for the inconvienced. The macro duplicated from the Main Sheet. Most likely is because all have number 1 in it.

Please see the attachment.

The main is the database. It should rightfully go into the respective Asset sheets.

**jindon** · 08-30-2012, 06:06 AM

According to your code

AllCells.Copy .Range("a" & .Cells(Rows.CountLarge, "A").End(xlUp).Row + 1)

It is adding the records after the existing records.

Do you want refresh all the sheets and paste the records as new?

**leeaw** · 09-02-2012, 09:56 PM

where do i paste the records? Thanks

**jindon** · 09-02-2012, 10:01 PM

Originally Posted by leeaw

where do i paste the records? Thanks

What do you mean? thanks.

**leeaw** · 09-03-2012, 01:23 AM

sorry i misunderstood your question.

Should be paste the records as new into the individual sheets.

**jindon** · 09-03-2012, 01:58 AM

I don't understand what you mean.

try

**leeaw** · 09-03-2012, 08:15 PM

yes yes this is the one. Thanks!!! it works.

Macro to Tabulate 100k Data into Individual Sheets

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Re: Macro to Tabulate 100k Data into Individual Sheets

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions