| Home |
| Search |
| Today's Posts |
|
|
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
looping programme require
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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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 |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
Hi Joel,
When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug? Rgds "Joel" wrote: 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 |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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" wrote: Hi Joel, When run to "For i = 0 To UBound(UniqueData, 1)", am asked for debug? Rgds "Joel" wrote: 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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| programme run help | Excel Programming | |||
| PROGRAMME HELP | Excel Programming | |||
| error in programme | Excel Discussion (Misc queries) | |||
| Material Require. Planning (MRP) & Capacity Require. Planning (CRP | Excel Programming | |||
| Audit Programme | Excel Programming | |||
Hybrid Mode
