looping programme require
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" wrote:
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" wrote:
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:R65535 C6))"
.Range("H" & NewRow) = "Total Out"
.Range("I" & NewRow).Formula = _
"=SUMPRODUCT(--(Sheet1!R1C1:R65535C1=""1 wk"")," & _
"--(Sheet1!R1C5:R65535C5=""CHF""),(Sheet1!R1C9:R65535 C9))"
.Range("J" & NewRow) = "Net"
.Range("J" & NewRow) = "=RC[-5]-RC[-2]"
End With
End If
Next wk
"Seeker" wrote:
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:R65535 C6))"
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:R65535 C9))"
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:R65535 C6))"
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:R65535 C9))"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "Net"
ActiveCell.Offset(0, 1).Select
ActiveCell.Formula = "=RC[-5]-RC[-2]"
Thanks in advance
Regards
|