VBA: Copy to new sheet with a twist poss Array required

Jack,

I started work on a solution that places the values into a two dimensional array, but then I had to go to work :barf: .

Hopefully will have something for you a bit later after I get home (if I can get the damn thing working).

Regards
Weasel

Hi Jack

Have a look at the attached - I hope its close to what you want.

HTH

The code is

Sub CopySpecial()

Dim c
Dim d

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For Each c In Selection

Sheets("Sheet2").Activate

d = (c.Row + 3) Mod 12
If d = 0 Then
Sheets("Sheet2").Range("A" & Int((c.Row / 12)) + 1).Value = c.Value
End If

d = (c.Row - 1) Mod 12
If d = 0 Then
Sheets("Sheet2").Range("b" & Int((c.Row / 12))).Value = c.Value
End If

d = (c.Row - 5) Mod 12
If d = 0 Then
Sheets("Sheet2").Range("c" & Int((c.Row / 12))).Value = c.Value
End If

Next c

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = False

End Sub

Hi there Jack, Had a bit of time this afternoon so thought I'd have a go:

Option Explicit


Sub Jack_ArrayCopy()
Dim rw As Long, cnt As Long
Dim Rng(), Wb As Workbook
Dim Sh1 As Worksheet, Sh2 As Worksheet
    
    Application.Calculation = xlCalculationManual
    Set Wb = ThisWorkbook: cnt = 0
    
    Set Sh1 = Wb.Sheets("Sheet1")
    With Sh1
        rw = .Range("A65536").End(xlUp).Row
        'round down 'cnt' in case decimal divison!
        cnt = WorksheetFunction.RoundDown((rw - 9) / 12, 0)
        'MsgBox "Copy Sheet1 A9:A" & rw & Chr(10) & " to " & "Sheet2 A1:A" & cnt + 1
        ReDim Rng(cnt, 2)
        cnt = 0
        For rw = 9 To rw Step 12
            Rng(cnt, 0) = .Cells(rw, 1)
            Rng(cnt, 1) = .Cells(rw + 4, 1)
            Rng(cnt, 2) = .Cells(rw + 8, 1)
            cnt = cnt + 1
        Next
    End With
        
    Set Sh2 = Wb.Sheets("Sheet2")
    With Sh2
        For rw = 1 To cnt
            .Cells(rw, 1) = Rng(rw - 1, 0)
            .Cells(rw, 2) = Rng(rw - 1, 1)
            .Cells(rw, 3) = Rng(rw - 1, 2)
        Next
    End With
    
    ReDim Rng(0, 0)
    Set Sh1 = Nothing
    Set Sh2 = Nothing
    Set Wb = Nothing
    Application.Calculation = xlCalculationAutomatic
End Sub

Hope this is something like what your after, see attached sample.

(Think sample is too large too attache, made over 5000 rows of data but it works pretty quick)

Sorry Jack,

I had misread the post but the code adapts easily enough. Try the following entering 13 in the input box as the data series is reapeated every 13th cell.

Regards
Weasel

Option Explicit
Option Base 1


Sub ForJack()


Dim data
Dim data2()
Dim iElem As Integer
Dim iDiv As Integer
Dim i As Integer
Dim x As Integer
Dim z As Integer


iElem = InputBox("Data Sets repeat every ? cells:") - 1
data = Range(Range("a9"), Range("a65536").End(xlUp)).Value
iDiv = WorksheetFunction.RoundUp(UBound(data) / iElem, 0)
ReDim data2(iDiv, iElem)


For z = 1 To iElem
For x = 1 To iDiv
For i = z To UBound(data) Step iElem
data2(x, z) = data(i, 1)
Next i
Next x
Next z


Sheets(2).Range("a1").Resize(iElem, iDiv).Value = WorksheetFunction.Transpose(data2)


End Sub

Sorry Guys,

I was using a really dumb set of test data which only looked like it was getting the job done. :0ops:

This should do it....maybe........ :dance3:

Regards
Weasel

Option Explicit
Option Base 1


Sub ForJack()


Dim data
Dim data2()
Dim iElem As Integer
Dim iDiv As Integer
Dim i As Integer
Dim x As Integer
Dim z As Integer


iElem = InputBox("Data Sets repeat every ? cells:") - 1
data = Range(Range("a9"), Range("a65536").End(xlUp)).Value
iDiv = WorksheetFunction.RoundUp(UBound(data) / iElem, 0)
ReDim data2(iDiv, iElem)


x = 1
z = 1


Do While z < iElem + 1
Do While x < iDiv
For i = z To UBound(data) Step iElem
data2(x, z) = data(i, 1)
x = x + 1
Next i
Loop
x = 1
z = z + 1
Loop


Sheets(2).Range("a1").Resize(iDiv, iElem).Value = data2


End Sub

Edit: I now get that you only want to group every 4th row (mind like a steel trap & quicker than greased lightning - me), which insomniacs code does admirably, whereas mine will group all rows. Great job insomniac - still not a completely wasted effort though - I can see what I have written coming in handy some day (just not today :biggrin: ).

Pesky Weasel, that's pretty nice solution, although you are transposing all the data it could be modified to transfer only the rows Jack want's.
Both ways are lightning fast, but yours is fractionally faster than mine!
I'm sure Jack would be keen for a modified version.

Insomniac,

I cant get my head around this. The only way I can think of displaying the data required is to then pass the individual columns from the 2D Array into 3 seperate 1D Arrays, which is essentailly what you have done only without the step of creating the 2D Array in the first place. As a consequence displaying less data will make my code take longer.
Do you see another way around this- Im only fairly new to arrays having only declared one for the first time a couple of weeks ago- and Im still coming to terms with them (but WOW aint they quicker!!!!)

Regards
Weasel

Pesky Weasel,

Modified your code to work the same as mine, the slow part of my code was applying the array back to sheet2, your line:
Sheets(2).Range("a1").Resize(iDiv, iElem).Value = data2 is a far better way.

Option Explicit
Option Base 1
 
Sub ForJack2()
 
Dim data
Dim data2()
Dim iDiv As Long
Dim i As Long
Dim x As Long


With Sheets("Sheet1")
    data = .Range(.Range("a9"), .Range("a65536").End(xlUp)).Value
End With


iDiv = WorksheetFunction.RoundUp(UBound(data) / 12, 0)
 ReDim data2(iDiv, 3)
  x = 1
    For i = 1 To UBound(data) Step 12
        data2(x, 1) = data(i, 1)
        data2(x, 2) = data(i + 4, 1)
        data2(x, 3) = data(i + 8, 1)
        x = x + 1
    Next i


Sheets(2).Range("a1").Resize(iDiv, 3).Value = data2
 
End Sub

Great Job Insomniac, should satisfy Jacks speed requirement. I really must get more into this area, I cant believe the speed advantages.

Regards
Weasel

Hi guys,

Interesting thread and a good solution as well

I just want to add that when we need to redimension (which is not good but necessary) arrays XL seems to handle arrays faster if the arrays are first dimensioned like data2(1,3) and then
ReDim data2(iDiv, 3).

For the really real arrays-neard the data-variabel should of course be sliced instead of looping...

Kind regards,
Dennis

Hiya Dennis,

Hows things up North today?

Just on your post:

1)
So if you give the array some dummy dimensions first before ReDimming it calculates faster?

2)

Quote

For the really real arrays-neard the data-variabel should of course be sliced instead of looping...

What is slicing? and how would it apply to this example?

Regards
Weasel

Hi Weasel,

We got the first snow last week so now we can skii until end of april/may next year :biggrin:

Q1: Yes, at least what I have found out.

Q2: Oops, it was not my intention to swing around words no one is familiar with...

Here is a link to some really nice array-slicings (remember it´s only for real array-neards) :biggrin:

http://www.xbeat.net/vbspeed/c_SliceLng.htm

Take care and all the best from,

Dennis

Good Skiing!!!!!!!!

Geez, your not wrong about the array nerds bit! I need to seriously upgrade my pocket protector and maybe even need to repair my glasses with sticky plaster to read this stuff......

But I will muddle through it as it sounds like a solution (albeit a complicated one) to the ultimate answer that I wanted to achieve on this post - which was to fill a two D array and then return subsets of the data based on either of the dimensions.

Thanks Dennis
Regards
weasel

Weasel,

I will *not* pay the bill for Your visit at a hospital in case You get lost among the arrays. :biggrin:

Meanwhile Alan Beban is also another good resource when it comes to arrays
(alltough the speed-consideration is not the primary issue):

http://home.pacbell.net/beban/

Take care with arrays!

Dennis