looping programme require

S

Seeker

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
 
J

Joel

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

Seeker said:
I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
 
S

Seeker

Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

Joel said:
I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

Seeker said:
I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
Click to expand...
 
J

Joel

See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


Seeker said:
Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

Joel said:
I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

Seeker said:
I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
Click to expand...
Click to expand...
 
S

Seeker

Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

Joel said:
See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


Seeker said:
Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

Joel said:
I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

I copied the code from my posting a ran again and it is working without
errors. The code should be place in a module page in VBa (not this workbook
or one of the worksheet pages). What error message are you getting?. Do you
have any blnak cells in column A?

I found one thing that could be causing the problem

from
Set DataRange = Range("A1:A" & Lastrow)
to
Set DataRange = sht1.Range("A1:A" & Lastrow)

Seeker said:
Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

Joel said:
See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


Seeker said:
Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

:

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
Click to expand...
Click to expand...
 
S

Seeker

Hi Joel,
I placed your code in Module 2. It was appended to my code (extract data
from different files and place in sheet 1, then rearrange the location). When
run into “For i = 0 To UBound(UniqueData, 1)â€, debug says Run time error
‘13’: Type mistmatch.
Is there anything related to the excel version please? I am using 2003.
Regards


Joel said:
I copied the code from my posting a ran again and it is working without
errors. The code should be place in a module page in VBa (not this workbook
or one of the worksheet pages). What error message are you getting?. Do you
have any blnak cells in column A?

I found one thing that could be causing the problem

from
Set DataRange = Range("A1:A" & Lastrow)
to
Set DataRange = sht1.Range("A1:A" & Lastrow)

Seeker said:
Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

Joel said:
See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


:

Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

:

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

I just noticed my easrlier response never got posted.

From
For i = 0 To UBound(UniqueData, 1)
to
For i = 0 To UBound(DuplicateData, 1)

I changed the name of the variable and tested the code above this line and
didn't make the change this line. I thought Duplicate was a better name for
whet I ws doing than Unique.

Seeker said:
Hi Joel,
I placed your code in Module 2. It was appended to my code (extract data
from different files and place in sheet 1, then rearrange the location). When
run into “For i = 0 To UBound(UniqueData, 1)â€, debug says Run time error
‘13’: Type mistmatch.
Is there anything related to the excel version please? I am using 2003.
Regards


Joel said:
I copied the code from my posting a ran again and it is working without
errors. The code should be place in a module page in VBa (not this workbook
or one of the worksheet pages). What error message are you getting?. Do you
have any blnak cells in column A?

I found one thing that could be causing the problem

from
Set DataRange = Range("A1:A" & Lastrow)
to
Set DataRange = sht1.Range("A1:A" & Lastrow)

Seeker said:
Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

:

See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


:

Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

:

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Thanks in advance
Regards
Click to expand...
Click to expand...
Click to expand...
 
S

Seeker

Joel,
Now when meet " If FilterCount > 0 Then" , debug says Run time error
‘13’: Type mistmatch.
Rgds

Joel said:
I just noticed my easrlier response never got posted.

From
For i = 0 To UBound(UniqueData, 1)
to
For i = 0 To UBound(DuplicateData, 1)

I changed the name of the variable and tested the code above this line and
didn't make the change this line. I thought Duplicate was a better name for
whet I ws doing than Unique.

Seeker said:
Hi Joel,
I placed your code in Module 2. It was appended to my code (extract data
from different files and place in sheet 1, then rearrange the location). When
run into “For i = 0 To UBound(UniqueData, 1)â€, debug says Run time error
‘13’: Type mistmatch.
Is there anything related to the excel version please? I am using 2003.
Regards


Joel said:
I copied the code from my posting a ran again and it is working without
errors. The code should be place in a module page in VBa (not this workbook
or one of the worksheet pages). What error message are you getting?. Do you
have any blnak cells in column A?

I found one thing that could be causing the problem

from
Set DataRange = Range("A1:A" & Lastrow)
to
Set DataRange = sht1.Range("A1:A" & Lastrow)

:

Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

:

See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


:

Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

:

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

I had an extra parenthesis in my sumproduct foormula that returned an error
instead of a number that gave the type mismatch. It is a simple change

"=""" & Period & """), extra-> ) " & _

FilterCount = Evaluate( _
"SumProduct(" & _
"--(" & sht1.Name & "!A2:A" & LastRow & _
"=""" & Period & """)," & _
"--(" & sht1.Name & "!E2:E" & LastRow & _
"=""" & Criteria & """))")

Seeker said:
Joel,
Now when meet " If FilterCount > 0 Then" , debug says Run time error
‘13’: Type mistmatch.
Rgds

Joel said:
I just noticed my easrlier response never got posted.

From
For i = 0 To UBound(UniqueData, 1)
to
For i = 0 To UBound(DuplicateData, 1)

I changed the name of the variable and tested the code above this line and
didn't make the change this line. I thought Duplicate was a better name for
whet I ws doing than Unique.

Seeker said:
Hi Joel,
I placed your code in Module 2. It was appended to my code (extract data
from different files and place in sheet 1, then rearrange the location). When
run into “For i = 0 To UBound(UniqueData, 1)â€, debug says Run time error
‘13’: Type mistmatch.
Is there anything related to the excel version please? I am using 2003.
Regards


:

I copied the code from my posting a ran again and it is working without
errors. The code should be place in a module page in VBa (not this workbook
or one of the worksheet pages). What error message are you getting?. Do you
have any blnak cells in column A?

I found one thing that could be causing the problem

from
Set DataRange = Range("A1:A" & Lastrow)
to
Set DataRange = sht1.Range("A1:A" & Lastrow)

:

Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

:

See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


:

Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

:

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "2 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""2
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
Click to expand...
Click to expand...
Click to expand...
 
S

Seeker

Hi Joel,
Sorry to come back late as I was too busy in past weekdays.
In your last post, just want to double confirm that add “extra->†to
FilterCount = Evaluate( "SumProduct ….and take away the second last
parenthesis, so the formula becomes FilterCount = Evaluate( "SumProduct(" &
"--(" & sht1.Name & "!A2:A" & LastRow &"=""" & Period & """), extra->)" &
"--(" & sht1.Name & "!E2:E" & LastRow & _ "=""" & Criteria & """)"), I did so
and macro ran thru without any prompt.
However, now when macro runs to With Sht2, If FilterCount > 0 Then, it shows
run time error ‘13’: Type mistmatch again.
After my own macro ran, all extracted data is located in sheet 1 without any
sorting. As I am a tyro to VBA language, would you please explain when sheet
2 is a blank sheet with no filter or other setting on, how could the
FilterCount performs? Would you please also enlighten me what is Ubound means
for?
Rgds


Joel said:
I had an extra parenthesis in my sumproduct foormula that returned an error
instead of a number that gave the type mismatch. It is a simple change

"=""" & Period & """), extra-> ) " & _

FilterCount = Evaluate( _
"SumProduct(" & _
"--(" & sht1.Name & "!A2:A" & LastRow & _
"=""" & Period & """)," & _
"--(" & sht1.Name & "!E2:E" & LastRow & _
"=""" & Criteria & """))")

Seeker said:
Joel,
Now when meet " If FilterCount > 0 Then" , debug says Run time error
‘13’: Type mistmatch.
Rgds

Joel said:
I just noticed my easrlier response never got posted.

From
For i = 0 To UBound(UniqueData, 1)
to
For i = 0 To UBound(DuplicateData, 1)

I changed the name of the variable and tested the code above this line and
didn't make the change this line. I thought Duplicate was a better name for
whet I ws doing than Unique.

:

Hi Joel,
I placed your code in Module 2. It was appended to my code (extract data
from different files and place in sheet 1, then rearrange the location). When
run into “For i = 0 To UBound(UniqueData, 1)â€, debug says Run time error
‘13’: Type mistmatch.
Is there anything related to the excel version please? I am using 2003.
Regards


:

I copied the code from my posting a ran again and it is working without
errors. The code should be place in a module page in VBa (not this workbook
or one of the worksheet pages). What error message are you getting?. Do you
have any blnak cells in column A?

I found one thing that could be causing the problem

from
Set DataRange = Range("A1:A" & Lastrow)
to
Set DataRange = sht1.Range("A1:A" & Lastrow)

:

Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug?
Rgds

:

See if this works

Sub FilterData()

CriteriaArray = 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 = Range("A1:A" & 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


For Each Criteria In CriteriaArray
For i = 0 To UBound(UniqueData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
Period = 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) = Criteria
.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!R1C1:R65535C1=""" & Period1 & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(" & _
"--(Sheet1!R1C1:R65535C1=""" & Period & """)," & _
"--(Sheet1!R1C5:R65535C5=""" & Criteria & """)," & _
"(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next i
Next Criteria

End Sub


:

Hi Joel,
Thanks for your kindness in composing the macro for me. My insufficient
information caused some missing parts in your macro.
1) You set AutoFilter Field 5 with Criteria1="CHF", it does not loop thru
rest choices (more then 10 items say GBP, USD…. etc.)?
2) How can AutoFilter Field 1 cope with “mth†please (should able to select
1 to 3 wk and 1 to 12 mth)?
Data transfer to sheet 2 must be fulfilled Filter 5 & 1 at same time
3) Can NewRow (those formula and added title) be always there in proven no
data meet Field 5 & Field 1 at same time?

Example:
Field 5 Field 1
Loop 1 CHF 1 wk Start of the loop
Loop 2 CHF 2 wk CHF has to loop till last period of “12 mthâ€
Loop 15 CHF 12 mth When CHF finished from 1 wk to 12 mth, then start with
next data in field 5
Loop 16 GBP 1 wk Another cycle on next data in field 5 with field 1 from
1wk to 12 mth

Regards

:

I think you were getting an error because autofilter did not find any items
that met the criteria. I added a test for this condition. I also made the
loop go from "1 wk" to "7 wk". I changed the for loop as necessary to get
all the weeks.

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

LastRow = Sht1.Range("A" & Rows.Count).End(xlUp).Row
Sht1.Range("A1:J1").AutoFilter _
Field:=5, _
Criteria1:="CHF"

For wk = 1 To 7
Criteria = wk & " wk"
'check if criteria was found
Set c = Sht1.Range("A2:J" & LastRow).Find(what:=Criteria, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Sht1.Range("A1:J1").AutoFilter _
Field:=1, _
Criteria1:=Criteria

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

With Sht2
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
CopyRange.Copy _
Destination:=.Range("C" & NewRow)
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & NewRow) = Criteria
.Range("B" & NewRow) = "CHF"
.Range("D" & NewRow).Formula = _
"=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
.Range("E" & NewRow) = "Total In"
.Range("F" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk

:

I am a tyro and have a macro done to extract data from different files and
placed in “sheet 1†columns A to J, a filter was added to select required
data and copy them to “sheet 2â€. Prime filter is in column E with different
currencies (tens of different currencies), each currencies need to check
another filter in column A if data contain in say 1 week, 1 month (15 tenors)
etc., add calculation at bottom after each loop. My macro only works for two
currencies, any more loop was rejected reason of “Procedure too largeâ€, your
assistance is needed to modify my macro to make it compile all looping.

Sheets("Sheet1").Select
Range("A1:J1").Select
Selection.AutoFilter Field:=5, Criteria1:="CHF"
Selection.AutoFilter Field:=1, Criteria1:="1 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Range("A65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Formula = "1 wk"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "CHF"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=vlookup(RC[-3],'Date_Calculation'!R1C11:R15C12,2)"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Total In"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C6:R65535C6))"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "Total Out"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1
wk""),--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"

Sheets("Sheet1").Select
Selection.AutoFilter Field:=1, Criteria1:="2 wk"
Range("A2:J2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Printout").Select
Range("A65536").End(xlUp).Offset(3, 0).Select
ActiveSheet.Paste
Click to expand...
Click to expand...
Click to expand...
 
J

Joel

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
 
S

Seeker

Hi Joel,
My be I didn’t 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 said:
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
Click to expand...
 
S

Seeker

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

Seeker said:
Hi Joel,
My be I didn’t 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 said:
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
Click to expand...
Click to expand...
 
J

Joel

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 said:
with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row should be
Range("A65536").End(xlUp).Offset(1, 0).Select

Seeker said:
Hi Joel,
My be I didn’t 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 said:
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
Click to expand...
Click to expand...
Click to expand...
 
S

Seeker

Hi Joel,
Thanks for your times in helping me in this project.

The presentation of your last script although meet with what I want (empty
row between different currencies groups, it only grabs the first tenor of “1
wkâ€, besides, same data has replicated itself so same group of data appeared
many times.

To make life easier, now I just use the sorting function on the same sheet
(sheet 1), with following script (copied from discussion group months ago),
am able to group data nicely with two empty line below each group.

What I need to know now is how to identify the right cell on first empty row
beneath each group to add in column E = “Totalâ€, column F and I =
sumproduct().

Dim lngRow As Long
For lngRow = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Range("A" & lngRow) <> Range("A" & lngRow - 1) Then
Rows(lngRow).EntireRow.Resize(2).Insert
///////////////////////
‘Should I add something here to locate the right cell reference for my
adding ?
///////////////////////
End If
Next

Thanks again in advance for your great assistance.
Rgds
 
J

Joel

I'm using SUMIF instead of Sumproduct. Sumif is more efficient than
suproduct. We already have the word total in column C for the rows we want
to add. I added a new total row at the end of each time period to total
columns F and I using a new variable FirstPeriod. I think this is better
than using a 2nd macro.

See changes below.


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

LastRow = _
Sht2.Range("A" & Rows.Count).End(xlUp).Row
FirstPeriod = LastRow + 2
For i = 0 To UBound(DuplicateData, 1)
'skip duplicte values
If DuplicateData(i, 1) = False Then
CurrencyX = DuplicateData(i, 0)

LastRow = _
Sht1.Range("A" & Rows.Count).End(xlUp).Row
'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

With Sht2
'add total of group
LastRow = _
.Range("A" & Rows.Count).End(xlUp).Row
totalRow = LastRow + 1
.Range("A" & totalRow) = Period
.Range("E" & totalRow) = "Total"
.Range("F" & totalRow).Formula = _
"=Sumif(C" & FirstPeriod & ":C" & LastRow & ",""Total""," & _
"F" & FirstPeriod & ":F" & LastRow & ")"
.Range("I" & totalRow).Formula = _
"=Sumif(C" & FirstPeriod & ":C" & LastRow & ",""Total""," & _
"I" & FirstPeriod & ":I" & LastRow & ")"
End With
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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Loop running really slow...? 3
Help with Index formula 2
Cell formula 3
Fill down to last row - copy formula to last row 2
Help me4 2
Type mismatch error on Find 4
Data samples 3
Run-time error '1004' 1

Top