Extracting summary to raw data

[nucleotide_boy]

Hi,

I have a set of data which lists numerous dog breeds and the number of dogs with and without a disease.

These values are all totalled and I don't have access to the raw data.

However, I want to try and reproduce the raw data for some work I'm doing. So I want to generate a list of every single dog represented in the summary data showing their breed and disease status.

This will take forever manually. Is there anyway to do this with VBA? I have attached an example of what I mean, including a manually produced example of the data I want to try and generate.

Any help would be hugely appreciated.

[nucleotide_boy]

Sorry, I forgot to attach the file.

[nucleotide_boy]

Bump! Please help if you can, I don't know where to begin!

[fecurtis]

To be perfectly honest, that'd be a difficult macro (for me anyway) to write. From the way it looks, it seems possible for your raw report to require more rows than Excel even has.

[Mikeopolo]

No it will take 47348 rows...

Mike

[Mikeopolo]

Try this macro:

NB Rename your summary sheet to SUMMARY
and create a sheet called DETAIL before you begin

Sub Copydata()
     
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim improw2 As Long 
    
    Dim rList As Range, rCell As Range
    Dim n1 As Long, n2 As Long, v1 As Long, v2 As Long
    
    Application.ScreenUpdating = False
    
    v1 = 0
    v2 = 1
    
    Set ws1 = ActiveWorkbook.Sheets("Summary")
    Set ws2 = ActiveWorkbook.Sheets("Detail")
    Set rList = ws1.Range("A2", Range("A" & Rows.count).End(xlUp)) ' list
         
    'beginning location on ws2
    improw2 = 1
    
    For Each rCell In rList
    
        n1 = rCell.Offset(0, 1).Value
        n2 = rCell.Offset(0, 2).Value
        
        For I = 1 To n1
        
            rCell.Copy Destination:=ws2.Cells(improw2, 1)
            ws2.Cells(improw2, 2).Value = v1
                   
            improw2 = improw2 + 1
            
            
        Next I
        
        For j = 1 To n2
        
            
            rCell.Copy Destination:=ws2.Cells(improw2, 1)
            ws2.Cells(improw2, 2).Value = v2
             
            improw2 = improw2 + 1
             
        Next j
    
    Next rCell
            
    
    Application.ScreenUpdating = True
    
End Sub

[jindon]

try

Sub test()
Dim a, i As Long, b(), n As Long, ii As Long
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(,3).Value
ReDim b(1 To Application.Sum(Range("b:c")), 1 To 2)
For i = 2 To UBound(a,1)
    For ii = 1 To a(i,2)
        n = n + 1
        b(n,1) = a(i,1) : b(n,2) = 0
    Next
    For ii = 1 To a(i,3)
        n = n + 1
        b(n,1) = a(i,1) : b(n,2) = 1
    Next
Next
Range("f1").Resize(n,2).Value = b
End Sub

[Mikeopolo]

Jindon, that's a neat method, will study it closely!

Nucleotide_boy, do you need any help getting these macros installed and running?

Regards
MIke

[nucleotide_boy]

try

Sub test()
Dim a, i As Long, b(), n As Long, ii As Long
a = Range("a1", Range("a" & Rows.Count).End(xlUp)).Resize(,3).Value
ReDim b(1 To Application.Sum(Range("b:c")), 1 To 2)
For i = 2 To UBound(a,1)
    For ii = 1 To a(i,2)
        n = n + 1
        b(n,1) = a(i,1) : b(n,2) = 0
    Next
    For ii = 1 To a(i,3)
        n = n + 1
        b(n,1) = a(i,1) : b(n,2) = 1
    Next
Next
Range("f1").Resize(n,2).Value = b
End Sub

That is absolutely perfect. Thank you so much!