this was a little tricky. We moved the data over two columns to so the 1st
two columns would have the period and currency. Instead of adding columns G
& I I'm adding I and L. I think this is correct. I also am sorting sheet 1
by date before I do anything else so the dates are in order.

Sub FilterData()

PeriodArray = Array("1 wk", "2 wk", "3 wk", _
"1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _
"7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth")

Dim DuplicateData() As Variant

Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")

With sht1
'turn off autofilter
If .AutoFilterMode Then
Columns.AutoFilter
End If

Lastrow = .Range("F" & Rows.Count).End(xlUp).Row

Set DataRange = .Range("F2:F" & Lastrow)
.Rows("2:" & Lastrow).Sort _
header:=xlNo, _
key1:=.Range("E2"), _
order1:=xlAscending
End With

With sht2
'clear sheet
.Cells.ClearContents
'copy header row from sheet 1
sht1.Rows(1).Copy _
Destination:=.Rows(1)
'add column for currency
.Columns("B").Insert
'Put currency in column b
.Range("B1") = "currency"

End With

'get unique value in data range
'2nd dimension of array will contain either
'True (unique) or false (duplicated)
ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1)

' move data from worksheet into DataRange
Index = 0
For Each cell In DataRange
DuplicateData(Index, 0) = cell
Index = Index + 1
Next cell

'find unique and duplicated values
For i = 0 To (UBound(DuplicateData, 1) - 1)
If IsEmpty(DuplicateData(i, 1)) Then
DuplicateData(i, 1) = False
For j = (i + 1) To UBound(DuplicateData, 1)
If DuplicateData(i, 0) = DuplicateData(j, 0) Then
DuplicateData(j, 1) = True
Exit For
End If
Next j
End If
Next i

With sht1
If Not .AutoFilterMode Then
'set autofilter
.Columns("A:F").AutoFilter
End If
End With

For Each Period In PeriodArray
For i = 0 To UBound(DuplicateData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
CurrencyX = DuplicateData(i, 0)

'check if combination exists of values exist
FilterCount = Evaluate( _
"SumProduct(" & _
"--(" & sht1.Name & "!A2:A" & Lastrow & _
"=""" & Period & """)," & _
"--(" & sht1.Name & "!F2:F" & Lastrow & _
"=""" & CurrencyX & """))")

With sht2
If FilterCount 0 Then
sht1.Columns("A:F").AutoFilter _
Field:=1, _
Criteria1:=Period

sht1.Columns("A:F").AutoFilter _
Field:=6, _
Criteria1:=CurrencyX

Set CopyRange = _
sht1.Range("B2:J" & Lastrow).SpecialCells( _
Type:=xlCellTypeVisible)


Lastrow = _
.Range("A" & Rows.Count).End(xlUp).Row
FirstRow = Lastrow + 2

CopyRange.Copy _
Destination:=.Range("C" & FirstRow)

Lastrow = .Range("G" & Rows.Count).End(xlUp).Row
TotalRow = Lastrow + 1

'put period in column A
.Range("A" & FirstRow & ":A" & Lastrow) = Period
'put currency in column B
.Range("B" & FirstRow & ":B" & Lastrow) = CurrencyX
.Range("I" & TotalRow).Formula = _
"=Sum(I" & FirstRow & ":I" & Lastrow & ")"
.Range("L" & TotalRow).Formula = _
"=Sum(L" & FirstRow & ":L" & Lastrow & ")"
Else
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
TotalRow = Lastrow + 2

.Range("I" & TotalRow) = 0
.Range("L" & TotalRow) = 0
End If

.Range("A" & TotalRow) = Period
.Range("B" & TotalRow) = CurrencyX
.Range("C" & TotalRow) = "Total"
.Range("H" & TotalRow) = "Total In"
.Range("J" & TotalRow) = "Total Out"
.Range("M" & TotalRow) = "Net"
.Range("N" & TotalRow).Formula = _
"=I" & TotalRow & "-L" & TotalRow

End With
End If
Next i
Next Period

With sht2
'autofit columns
Lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range("1:" & Lastcol).Columns.AutoFit
End With

With sht1
'turn off autofilter
If .AutoFilterMode Then
Columns.AutoFilter
End If
End With
End Sub




"Seeker" wrote:

with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row should be
Range("A65536").End(xlUp).Offset(1, 0).Select

"Seeker" wrote:

Hi Joel,
My be I didnt explain myself clear enough, thus caused the problem in your
coding.
Your last code picks periods and dates to sheet 2 with the formula next to
them (not transfer relative data in same row from sheet 1 to sheet 2 and add
a sub total to each group at next line of that group, besides, running time
of your code took too long because of the array function?)
My arrangement in Sheet 1 as follow
Data in column A has 15 possible period (from 1 wk, 2 wk, 3 wk, 1 mth to 12
mth),
Data in column B, C, D, H,I,K are informative data
Data in column E are dates
Data in column F are currency symbols (say AUD, CAD, GBP, USD .etc)
Data in column G & J are amount (either one has figure only)
Need some code like below:
If
AutoFilter Field:=6 (column F), Criteria1:=€�AUD€� and AutoFilter
Field:=1(column A), Criteria1:=€�1 wk€�
Then
sort (column E, date),
copy rows with data from column A to K to sheet 2
with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row
add sub total in column G & J in sheet 2
Next
If end of file
Exit
End if
Loop
End If

Each currency has to be gone thru from 1wk to 12 mth. I.E. if I have 10
currencies, the loop has to extract data 150 times (10 currencies X 15
period) and add their respective subtotal. Don't worry about the formulas, I
can figure it out myself.
Regards


"Joel" wrote:

I just finish test the code the best I could. Found a few errors. the
results probably isn't going to be perfect but the code should run and get
data under every case. I don't think the formulas are correct, but I don't
know what is in each column and the actual results you are looking for. I
also changed you sumproductsd formulas so the weren't going to row 65536.
These sumproducts were taking a long time to execute. I'm now only going to
the last row of the actual data.

UBound get the size of an array.

Sub FilterData()

PeriodArray = Array("1 wk", "2 wk", "3 wk", _
"1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _
"7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth")

Dim DuplicateData() As Variant



Set sht1 = Sheets("Sheet1")
Set Sht2 = Sheets("Sheet2")

LastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row

Set DataRange = sht1.Range("E2:E" & LastRow)

'get unique value in data range
'2nd dimension of array will contain either
'True (unique) or false (duplicated)
ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1)

' move data from worksheet into DataRange
Index = 0
For Each cell In DataRange
DuplicateData(Index, 0) = cell
Index = Index + 1
Next cell

'find unique and duplicated values
For i = 0 To (UBound(DuplicateData, 1) - 1)
If IsEmpty(DuplicateData(i, 1)) Then
DuplicateData(i, 1) = False
For j = (i + 1) To UBound(DuplicateData, 1)
If DuplicateData(i, 0) = DuplicateData(j, 0) Then
DuplicateData(j, 1) = True
Exit For
End If
Next j
End If
Next i

With sht1
If Not .AutoFilterMode Then
'set autofilter
.Columns("A:J").AutoFilter
End If
End With

For Each Period In PeriodArray
For i = 0 To UBound(DuplicateData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Criteria = DuplicateData(i, 0)

'check if combination exists of values exist
FilterCount = Evaluate( _
"SumProduct(" & _
"--(" & sht1.Name & "!A2:A" & LastRow & _
"=""" & Period & """)," & _
"--(" & sht1.Name & "!E2:E" & LastRow & _
"=""" & Criteria & """))")

With Sht2
If FilterCount 0 Then
sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Period

sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:=Criteria

Set CopyRange = _
sht1.Range("A2:J" & LastRow).SpecialCells( _
Type:=xlCellTypeVisible)


LastRow = _
.Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
End If

LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1

.Range("A" & NewRow) = Period
.Range("B" & NewRow) = Criteria
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3]," & _
"'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow) = _
"=SUMPRODUCT(" & _
"--(Sheet1!R2C1:R" & LastRow & "C1=""" & Period1 &
""")," & _
"--(Sheet1!R2C5:R" & LastRow & "C1=""" & Criteria &
""")," & _
"(Sheet1!R2C6:R" & LastRow & "))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R" & LastRow & "C1=""" & Period &
""")," & _
"--(Sheet1!R1C5:R" & LastRow & "C5=""" & Criteria &
""")," & _
"(Sheet1!R1C9:R" & LastRow & "C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Period

End Sub