| 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 |
|
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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" wrote: 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 |
|
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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" wrote: 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" wrote: 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 |
|
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
Joel,
Now when meet " If FilterCount 0 Then" , debug says Run time error 13: Type mistmatch. Rgds "Joel" wrote: 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" wrote: 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" wrote: 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]" |
|
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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" wrote: Joel, Now when meet " If FilterCount 0 Then" , debug says Run time error 13: Type mistmatch. Rgds "Joel" wrote: 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" wrote: 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" wrote: 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 |
|
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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" wrote: 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" wrote: Joel, Now when meet " If FilterCount 0 Then" , debug says Run time error 13: Type mistmatch. Rgds "Joel" wrote: 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" wrote: 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" wrote: 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 |
|
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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 |
|
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
Hi Joel,
My be I didnt explain myself clear enough, thus caused the problem in your coding. Your last code picks periods and dates to sheet 2 with the formula next to them (not transfer relative data in same row from sheet 1 to sheet 2 and add a sub total to each group at next line of that group, besides, running time of your code took too long because of the array function?) My arrangement in Sheet 1 as follow Data in column A has 15 possible period (from 1 wk, 2 wk, 3 wk, 1 mth to 12 mth), Data in column B, C, D, H,I,K are informative data Data in column E are dates Data in column F are currency symbols (say AUD, CAD, GBP, USD .etc) Data in column G & J are amount (either one has figure only) Need some code like below: If AutoFilter Field:=6 (column F), Criteria1:=AUD and AutoFilter Field:=1(column A), Criteria1:=1 wk Then sort (column E, date), copy rows with data from column A to K to sheet 2 with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row add sub total in column G & J in sheet 2 Next If end of file Exit End if Loop End If Each currency has to be gone thru from 1wk to 12 mth. I.E. if I have 10 currencies, the loop has to extract data 150 times (10 currencies X 15 period) and add their respective subtotal. Don't worry about the formulas, I can figure it out myself. Regards "Joel" wrote: I just finish test the code the best I could. Found a few errors. the results probably isn't going to be perfect but the code should run and get data under every case. I don't think the formulas are correct, but I don't know what is in each column and the actual results you are looking for. I also changed you sumproductsd formulas so the weren't going to row 65536. These sumproducts were taking a long time to execute. I'm now only going to the last row of the actual data. UBound get the size of an array. Sub FilterData() PeriodArray = Array("1 wk", "2 wk", "3 wk", _ "1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _ "7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth") Dim DuplicateData() As Variant Set sht1 = Sheets("Sheet1") Set Sht2 = Sheets("Sheet2") LastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row Set DataRange = sht1.Range("E2:E" & LastRow) 'get unique value in data range '2nd dimension of array will contain either 'True (unique) or false (duplicated) ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1) ' move data from worksheet into DataRange Index = 0 For Each cell In DataRange DuplicateData(Index, 0) = cell Index = Index + 1 Next cell 'find unique and duplicated values For i = 0 To (UBound(DuplicateData, 1) - 1) If IsEmpty(DuplicateData(i, 1)) Then DuplicateData(i, 1) = False For j = (i + 1) To UBound(DuplicateData, 1) If DuplicateData(i, 0) = DuplicateData(j, 0) Then DuplicateData(j, 1) = True Exit For End If Next j End If Next i With sht1 If Not .AutoFilterMode Then 'set autofilter .Columns("A:J").AutoFilter End If End With For Each Period In PeriodArray For i = 0 To UBound(DuplicateData, 1) 'skip duplicte values If DuplicateData(i, 1) = False Then Criteria = DuplicateData(i, 0) 'check if combination exists of values exist FilterCount = Evaluate( _ "SumProduct(" & _ "--(" & sht1.Name & "!A2:A" & LastRow & _ "=""" & Period & """)," & _ "--(" & sht1.Name & "!E2:E" & LastRow & _ "=""" & Criteria & """))") With Sht2 If FilterCount 0 Then sht1.Range("A1:J1").AutoFilter _ Field:=1, _ Criteria1:=Period sht1.Range("A1:J1").AutoFilter _ Field:=5, _ Criteria1:=Criteria Set CopyRange = _ sht1.Range("A2:J" & LastRow).SpecialCells( _ Type:=xlCellTypeVisible) LastRow = _ .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 CopyRange.Copy _ Destination:=.Range("C" & NewRow) End If LastRow = .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 .Range("A" & NewRow) = Period .Range("B" & NewRow) = Criteria .Range("D" & NewRow).Formula = _ "=vlookup(RC[-3]," & _ "'Date_Calculation'!R1C11:R15C12,2)" .Range("E" & NewRow) = "Total In" .Range("F" & NewRow) = _ "=SUMPRODUCT(" & _ "--(Sheet1!R2C1:R" & LastRow & "C1=""" & Period1 & """)," & _ "--(Sheet1!R2C5:R" & LastRow & "C1=""" & Criteria & """)," & _ "(Sheet1!R2C6:R" & LastRow & "))" .Range("H" & NewRow) = "Total Out" .Range("I" & NewRow).Formula = _ "=SUMPRODUCT(" & _ "--(Sheet1!R1C1:R" & LastRow & "C1=""" & Period & """)," & _ "--(Sheet1!R1C5:R" & LastRow & "C5=""" & Criteria & """)," & _ "(Sheet1!R1C9:R" & LastRow & "C9))" .Range("J" & NewRow) = "Net" .Range("J" & NewRow) = "=RC[-5]-RC[-2]" End With End If Next i Next Period End Sub |
|
#14
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row should be
Range("A65536").End(xlUp).Offset(1, 0).Select "Seeker" wrote: Hi Joel, My be I didnt explain myself clear enough, thus caused the problem in your coding. Your last code picks periods and dates to sheet 2 with the formula next to them (not transfer relative data in same row from sheet 1 to sheet 2 and add a sub total to each group at next line of that group, besides, running time of your code took too long because of the array function?) My arrangement in Sheet 1 as follow Data in column A has 15 possible period (from 1 wk, 2 wk, 3 wk, 1 mth to 12 mth), Data in column B, C, D, H,I,K are informative data Data in column E are dates Data in column F are currency symbols (say AUD, CAD, GBP, USD .etc) Data in column G & J are amount (either one has figure only) Need some code like below: If AutoFilter Field:=6 (column F), Criteria1:=AUD and AutoFilter Field:=1(column A), Criteria1:=1 wk Then sort (column E, date), copy rows with data from column A to K to sheet 2 with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row add sub total in column G & J in sheet 2 Next If end of file Exit End if Loop End If Each currency has to be gone thru from 1wk to 12 mth. I.E. if I have 10 currencies, the loop has to extract data 150 times (10 currencies X 15 period) and add their respective subtotal. Don't worry about the formulas, I can figure it out myself. Regards "Joel" wrote: I just finish test the code the best I could. Found a few errors. the results probably isn't going to be perfect but the code should run and get data under every case. I don't think the formulas are correct, but I don't know what is in each column and the actual results you are looking for. I also changed you sumproductsd formulas so the weren't going to row 65536. These sumproducts were taking a long time to execute. I'm now only going to the last row of the actual data. UBound get the size of an array. Sub FilterData() PeriodArray = Array("1 wk", "2 wk", "3 wk", _ "1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _ "7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth") Dim DuplicateData() As Variant Set sht1 = Sheets("Sheet1") Set Sht2 = Sheets("Sheet2") LastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row Set DataRange = sht1.Range("E2:E" & LastRow) 'get unique value in data range '2nd dimension of array will contain either 'True (unique) or false (duplicated) ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1) ' move data from worksheet into DataRange Index = 0 For Each cell In DataRange DuplicateData(Index, 0) = cell Index = Index + 1 Next cell 'find unique and duplicated values For i = 0 To (UBound(DuplicateData, 1) - 1) If IsEmpty(DuplicateData(i, 1)) Then DuplicateData(i, 1) = False For j = (i + 1) To UBound(DuplicateData, 1) If DuplicateData(i, 0) = DuplicateData(j, 0) Then DuplicateData(j, 1) = True Exit For End If Next j End If Next i With sht1 If Not .AutoFilterMode Then 'set autofilter .Columns("A:J").AutoFilter End If End With For Each Period In PeriodArray For i = 0 To UBound(DuplicateData, 1) 'skip duplicte values If DuplicateData(i, 1) = False Then Criteria = DuplicateData(i, 0) 'check if combination exists of values exist FilterCount = Evaluate( _ "SumProduct(" & _ "--(" & sht1.Name & "!A2:A" & LastRow & _ "=""" & Period & """)," & _ "--(" & sht1.Name & "!E2:E" & LastRow & _ "=""" & Criteria & """))") With Sht2 If FilterCount 0 Then sht1.Range("A1:J1").AutoFilter _ Field:=1, _ Criteria1:=Period sht1.Range("A1:J1").AutoFilter _ Field:=5, _ Criteria1:=Criteria Set CopyRange = _ sht1.Range("A2:J" & LastRow).SpecialCells( _ Type:=xlCellTypeVisible) LastRow = _ .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 CopyRange.Copy _ Destination:=.Range("C" & NewRow) End If LastRow = .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 .Range("A" & NewRow) = Period .Range("B" & NewRow) = Criteria .Range("D" & NewRow).Formula = _ "=vlookup(RC[-3]," & _ "'Date_Calculation'!R1C11:R15C12,2)" .Range("E" & NewRow) = "Total In" .Range("F" & NewRow) = _ "=SUMPRODUCT(" & _ "--(Sheet1!R2C1:R" & LastRow & "C1=""" & Period1 & """)," & _ "--(Sheet1!R2C5:R" & LastRow & "C1=""" & Criteria & """)," & _ "(Sheet1!R2C6:R" & LastRow & "))" .Range("H" & NewRow) = "Total Out" .Range("I" & NewRow).Formula = _ "=SUMPRODUCT(" & _ "--(Sheet1!R1C1:R" & LastRow & "C1=""" & Period & """)," & _ "--(Sheet1!R1C5:R" & LastRow & "C5=""" & Criteria & """)," & _ "(Sheet1!R1C9:R" & LastRow & "C9))" .Range("J" & NewRow) = "Net" .Range("J" & NewRow) = "=RC[-5]-RC[-2]" End With End If Next i Next Period End Sub |
|
#15
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
this was a little tricky. We moved the data over two columns to so the 1st
two columns would have the period and currency. Instead of adding columns G & I I'm adding I and L. I think this is correct. I also am sorting sheet 1 by date before I do anything else so the dates are in order. Sub FilterData() PeriodArray = Array("1 wk", "2 wk", "3 wk", _ "1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _ "7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth") Dim DuplicateData() As Variant Set sht1 = Sheets("Sheet1") Set sht2 = Sheets("Sheet2") With sht1 'turn off autofilter If .AutoFilterMode Then Columns.AutoFilter End If Lastrow = .Range("F" & Rows.Count).End(xlUp).Row Set DataRange = .Range("F2:F" & Lastrow) .Rows("2:" & Lastrow).Sort _ header:=xlNo, _ key1:=.Range("E2"), _ order1:=xlAscending End With With sht2 'clear sheet .Cells.ClearContents 'copy header row from sheet 1 sht1.Rows(1).Copy _ Destination:=.Rows(1) 'add column for currency .Columns("B").Insert 'Put currency in column b .Range("B1") = "currency" End With 'get unique value in data range '2nd dimension of array will contain either 'True (unique) or false (duplicated) ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1) ' move data from worksheet into DataRange Index = 0 For Each cell In DataRange DuplicateData(Index, 0) = cell Index = Index + 1 Next cell 'find unique and duplicated values For i = 0 To (UBound(DuplicateData, 1) - 1) If IsEmpty(DuplicateData(i, 1)) Then DuplicateData(i, 1) = False For j = (i + 1) To UBound(DuplicateData, 1) If DuplicateData(i, 0) = DuplicateData(j, 0) Then DuplicateData(j, 1) = True Exit For End If Next j End If Next i With sht1 If Not .AutoFilterMode Then 'set autofilter .Columns("A:F").AutoFilter End If End With For Each Period In PeriodArray For i = 0 To UBound(DuplicateData, 1) 'skip duplicte values If DuplicateData(i, 1) = False Then CurrencyX = DuplicateData(i, 0) 'check if combination exists of values exist FilterCount = Evaluate( _ "SumProduct(" & _ "--(" & sht1.Name & "!A2:A" & Lastrow & _ "=""" & Period & """)," & _ "--(" & sht1.Name & "!F2:F" & Lastrow & _ "=""" & CurrencyX & """))") With sht2 If FilterCount 0 Then sht1.Columns("A:F").AutoFilter _ Field:=1, _ Criteria1:=Period sht1.Columns("A:F").AutoFilter _ Field:=6, _ Criteria1:=CurrencyX Set CopyRange = _ sht1.Range("B2:J" & Lastrow).SpecialCells( _ Type:=xlCellTypeVisible) Lastrow = _ .Range("A" & Rows.Count).End(xlUp).Row FirstRow = Lastrow + 2 CopyRange.Copy _ Destination:=.Range("C" & FirstRow) Lastrow = .Range("G" & Rows.Count).End(xlUp).Row TotalRow = Lastrow + 1 'put period in column A .Range("A" & FirstRow & ":A" & Lastrow) = Period 'put currency in column B .Range("B" & FirstRow & ":B" & Lastrow) = CurrencyX .Range("I" & TotalRow).Formula = _ "=Sum(I" & FirstRow & ":I" & Lastrow & ")" .Range("L" & TotalRow).Formula = _ "=Sum(L" & FirstRow & ":L" & Lastrow & ")" Else Lastrow = .Range("A" & Rows.Count).End(xlUp).Row TotalRow = Lastrow + 2 .Range("I" & TotalRow) = 0 .Range("L" & TotalRow) = 0 End If .Range("A" & TotalRow) = Period .Range("B" & TotalRow) = CurrencyX .Range("C" & TotalRow) = "Total" .Range("H" & TotalRow) = "Total In" .Range("J" & TotalRow) = "Total Out" .Range("M" & TotalRow) = "Net" .Range("N" & TotalRow).Formula = _ "=I" & TotalRow & "-L" & TotalRow End With End If Next i Next Period With sht2 'autofit columns Lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column .Range("1:" & Lastcol).Columns.AutoFit End With With sht1 'turn off autofilter If .AutoFilterMode Then Columns.AutoFilter End If End With End Sub "Seeker" wrote: with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row should be Range("A65536").End(xlUp).Offset(1, 0).Select "Seeker" wrote: Hi Joel, My be I didnt explain myself clear enough, thus caused the problem in your coding. Your last code picks periods and dates to sheet 2 with the formula next to them (not transfer relative data in same row from sheet 1 to sheet 2 and add a sub total to each group at next line of that group, besides, running time of your code took too long because of the array function?) My arrangement in Sheet 1 as follow Data in column A has 15 possible period (from 1 wk, 2 wk, 3 wk, 1 mth to 12 mth), Data in column B, C, D, H,I,K are informative data Data in column E are dates Data in column F are currency symbols (say AUD, CAD, GBP, USD .etc) Data in column G & J are amount (either one has figure only) Need some code like below: If AutoFilter Field:=6 (column F), Criteria1:=AUD and AutoFilter Field:=1(column A), Criteria1:=1 wk Then sort (column E, date), copy rows with data from column A to K to sheet 2 with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row add sub total in column G & J in sheet 2 Next If end of file Exit End if Loop End If Each currency has to be gone thru from 1wk to 12 mth. I.E. if I have 10 currencies, the loop has to extract data 150 times (10 currencies X 15 period) and add their respective subtotal. Don't worry about the formulas, I can figure it out myself. Regards "Joel" wrote: I just finish test the code the best I could. Found a few errors. the results probably isn't going to be perfect but the code should run and get data under every case. I don't think the formulas are correct, but I don't know what is in each column and the actual results you are looking for. I also changed you sumproductsd formulas so the weren't going to row 65536. These sumproducts were taking a long time to execute. I'm now only going to the last row of the actual data. UBound get the size of an array. Sub FilterData() PeriodArray = Array("1 wk", "2 wk", "3 wk", _ "1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _ "7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth") Dim DuplicateData() As Variant Set sht1 = Sheets("Sheet1") Set Sht2 = Sheets("Sheet2") LastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row Set DataRange = sht1.Range("E2:E" & LastRow) 'get unique value in data range '2nd dimension of array will contain either 'True (unique) or false (duplicated) ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1) ' move data from worksheet into DataRange Index = 0 For Each cell In DataRange DuplicateData(Index, 0) = cell Index = Index + 1 Next cell 'find unique and duplicated values For i = 0 To (UBound(DuplicateData, 1) - 1) If IsEmpty(DuplicateData(i, 1)) Then DuplicateData(i, 1) = False For j = (i + 1) To UBound(DuplicateData, 1) If DuplicateData(i, 0) = DuplicateData(j, 0) Then DuplicateData(j, 1) = True Exit For End If Next j End If Next i With sht1 If Not .AutoFilterMode Then 'set autofilter .Columns("A:J").AutoFilter End If End With For Each Period In PeriodArray For i = 0 To UBound(DuplicateData, 1) 'skip duplicte values If DuplicateData(i, 1) = False Then Criteria = DuplicateData(i, 0) 'check if combination exists of values exist FilterCount = Evaluate( _ "SumProduct(" & _ "--(" & sht1.Name & "!A2:A" & LastRow & _ "=""" & Period & """)," & _ "--(" & sht1.Name & "!E2:E" & LastRow & _ "=""" & Criteria & """))") With Sht2 If FilterCount 0 Then sht1.Range("A1:J1").AutoFilter _ Field:=1, _ Criteria1:=Period sht1.Range("A1:J1").AutoFilter _ Field:=5, _ Criteria1:=Criteria Set CopyRange = _ sht1.Range("A2:J" & LastRow).SpecialCells( _ Type:=xlCellTypeVisible) LastRow = _ .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 CopyRange.Copy _ Destination:=.Range("C" & NewRow) End If LastRow = .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 .Range("A" & NewRow) = Period .Range("B" & NewRow) = Criteria .Range("D" & NewRow).Formula = _ "=vlookup(RC[-3]," & _ "'Date_Calculation'!R1C11:R15C12,2)" .Range("E" & NewRow) = "Total In" .Range("F" & NewRow) = _ "=SUMPRODUCT(" & _ "--(Sheet1!R2C1:R" & LastRow & "C1=""" & Period1 & """)," & _ "--(Sheet1!R2C5:R" & LastRow & "C1=""" & Criteria & """)," & _ "(Sheet1!R2C6:R" & LastRow & "))" .Range("H" & NewRow) = "Total Out" .Range("I" & NewRow).Formula = _ "=SUMPRODUCT(" & _ "--(Sheet1!R1C1:R" & LastRow & "C1=""" & Period & """)," & _ "--(Sheet1!R1C5:R" & LastRow & "C5=""" & Criteria & """)," & _ "(Sheet1!R1C9:R" & LastRow & "C9))" .Range("J" & NewRow) = "Net" .Range("J" & NewRow) = "=RC[-5]-RC[-2]" End With End If Next i Next Period End Sub |
|
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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 "Joel" wrote: this was a little tricky. We moved the data over two columns to so the 1st two columns would have the period and currency. Instead of adding columns G & I I'm adding I and L. I think this is correct. I also am sorting sheet 1 by date before I do anything else so the dates are in order. Sub FilterData() PeriodArray = Array("1 wk", "2 wk", "3 wk", _ "1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _ "7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth") Dim DuplicateData() As Variant Set sht1 = Sheets("Sheet1") Set sht2 = Sheets("Sheet2") With sht1 'turn off autofilter If .AutoFilterMode Then Columns.AutoFilter End If Lastrow = .Range("F" & Rows.Count).End(xlUp).Row Set DataRange = .Range("F2:F" & Lastrow) .Rows("2:" & Lastrow).Sort _ header:=xlNo, _ key1:=.Range("E2"), _ order1:=xlAscending End With With sht2 'clear sheet .Cells.ClearContents 'copy header row from sheet 1 sht1.Rows(1).Copy _ Destination:=.Rows(1) 'add column for currency .Columns("B").Insert 'Put currency in column b .Range("B1") = "currency" End With 'get unique value in data range '2nd dimension of array will contain either 'True (unique) or false (duplicated) ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1) ' move data from worksheet into DataRange Index = 0 For Each cell In DataRange DuplicateData(Index, 0) = cell Index = Index + 1 Next cell 'find unique and duplicated values For i = 0 To (UBound(DuplicateData, 1) - 1) If IsEmpty(DuplicateData(i, 1)) Then DuplicateData(i, 1) = False For j = (i + 1) To UBound(DuplicateData, 1) If DuplicateData(i, 0) = DuplicateData(j, 0) Then DuplicateData(j, 1) = True Exit For End If Next j End If Next i With sht1 If Not .AutoFilterMode Then 'set autofilter .Columns("A:F").AutoFilter End If End With For Each Period In PeriodArray For i = 0 To UBound(DuplicateData, 1) 'skip duplicte values If DuplicateData(i, 1) = False Then CurrencyX = DuplicateData(i, 0) 'check if combination exists of values exist FilterCount = Evaluate( _ "SumProduct(" & _ "--(" & sht1.Name & "!A2:A" & Lastrow & _ "=""" & Period & """)," & _ "--(" & sht1.Name & "!F2:F" & Lastrow & _ "=""" & CurrencyX & """))") With sht2 If FilterCount 0 Then sht1.Columns("A:F").AutoFilter _ Field:=1, _ Criteria1:=Period sht1.Columns("A:F").AutoFilter _ Field:=6, _ Criteria1:=CurrencyX Set CopyRange = _ sht1.Range("B2:J" & Lastrow).SpecialCells( _ Type:=xlCellTypeVisible) Lastrow = _ .Range("A" & Rows.Count).End(xlUp).Row FirstRow = Lastrow + 2 CopyRange.Copy _ Destination:=.Range("C" & FirstRow) Lastrow = .Range("G" & Rows.Count).End(xlUp).Row TotalRow = Lastrow + 1 'put period in column A .Range("A" & FirstRow & ":A" & Lastrow) = Period 'put currency in column B .Range("B" & FirstRow & ":B" & Lastrow) = CurrencyX .Range("I" & TotalRow).Formula = _ "=Sum(I" & FirstRow & ":I" & Lastrow & ")" .Range("L" & TotalRow).Formula = _ "=Sum(L" & FirstRow & ":L" & Lastrow & ")" Else Lastrow = .Range("A" & Rows.Count).End(xlUp).Row TotalRow = Lastrow + 2 .Range("I" & TotalRow) = 0 .Range("L" & TotalRow) = 0 End If .Range("A" & TotalRow) = Period .Range("B" & TotalRow) = CurrencyX .Range("C" & TotalRow) = "Total" .Range("H" & TotalRow) = "Total In" .Range("J" & TotalRow) = "Total Out" .Range("M" & TotalRow) = "Net" .Range("N" & TotalRow).Formula = _ "=I" & TotalRow & "-L" & TotalRow End With End If Next i Next Period With sht2 'autofit columns Lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column .Range("1:" & Lastcol).Columns.AutoFit End With With sht1 'turn off autofilter If .AutoFilterMode Then Columns.AutoFilter End If End With End Sub "Seeker" wrote: with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row should be Range("A65536").End(xlUp).Offset(1, 0).Select "Seeker" wrote: Hi Joel, My be I didnt explain myself clear enough, thus caused the problem in your coding. Your last code picks periods and dates to sheet 2 with the formula next to them (not transfer relative data in same row from sheet 1 to sheet 2 and add a sub total to each group at next line of that group, besides, running time of your code took too long because of the array function?) My arrangement in Sheet 1 as follow Data in column A has 15 possible period (from 1 wk, 2 wk, 3 wk, 1 mth to 12 mth), Data in column B, C, D, H,I,K are informative data Data in column E are dates Data in column F are currency symbols (say AUD, CAD, GBP, USD .etc) Data in column G & J are amount (either one has figure only) Need some code like below: If AutoFilter Field:=6 (column F), Criteria1:=AUD and AutoFilter Field:=1(column A), Criteria1:=1 wk Then sort (column E, date), copy rows with data from column A to K to sheet 2 with sheet 2 .Range("A" & Rows.Count).End(xlUp).Row add sub total in column G & J in sheet 2 Next If end of file Exit End if Loop End If Each currency has to be gone thru from 1wk to 12 mth. I.E. if I have 10 currencies, the loop has to extract data 150 times (10 currencies X 15 period) and add their respective subtotal. Don't worry about the formulas, I can figure it out myself. Regards "Joel" wrote: I just finish test the code the best I could. Found a few errors. the results probably isn't going to be perfect but the code should run and get data under every case. I don't think the formulas are correct, but I don't know what is in each column and the actual results you are looking for. I also changed you sumproductsd formulas so the weren't going to row 65536. These sumproducts were taking a long time to execute. I'm now only going to the last row of the actual data. UBound get the size of an array. Sub FilterData() PeriodArray = Array("1 wk", "2 wk", "3 wk", _ "1 mth", "2 mth", "3 mth", "4 mth", "5 mth", "6 mth", _ "7 mth", "8 mth", "9 mth", "10 mth", "11 mth", "12 mth") Dim DuplicateData() As Variant Set sht1 = Sheets("Sheet1") Set Sht2 = Sheets("Sheet2") LastRow = sht1.Range("A" & Rows.Count).End(xlUp).Row Set DataRange = sht1.Range("E2:E" & LastRow) 'get unique value in data range '2nd dimension of array will contain either 'True (unique) or false (duplicated) ReDim DuplicateData(0 To (DataRange.Count - 1), 0 To 1) ' move data from worksheet into DataRange Index = 0 For Each cell In DataRange DuplicateData(Index, 0) = cell Index = Index + 1 Next cell 'find unique and duplicated values For i = 0 To (UBound(DuplicateData, 1) - 1) If IsEmpty(DuplicateData(i, 1)) Then DuplicateData(i, 1) = False For j = (i + 1) To UBound(DuplicateData, 1) If DuplicateData(i, 0) = DuplicateData(j, 0) Then DuplicateData(j, 1) = True Exit For End If Next j End If Next i With sht1 If Not .AutoFilterMode Then 'set autofilter .Columns("A:J").AutoFilter End If End With For Each Period In PeriodArray For i = 0 To UBound(DuplicateData, 1) 'skip duplicte values If DuplicateData(i, 1) = False Then Criteria = DuplicateData(i, 0) 'check if combination exists of values exist FilterCount = Evaluate( _ "SumProduct(" & _ "--(" & sht1.Name & "!A2:A" & LastRow & _ "=""" & Period & """)," & _ "--(" & sht1.Name & "!E2:E" & LastRow & _ "=""" & Criteria & """))") With Sht2 If FilterCount 0 Then sht1.Range("A1:J1").AutoFilter _ Field:=1, _ Criteria1:=Period sht1.Range("A1:J1").AutoFilter _ Field:=5, _ Criteria1:=Criteria Set CopyRange = _ sht1.Range("A2:J" & LastRow).SpecialCells( _ Type:=xlCellTypeVisible) LastRow = _ .Range("A" & Rows.Count).End(xlUp).Row NewRow = LastRow + 1 CopyRange.Copy _ |
|
#17
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
looping programme require
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 |
| 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 | |||
Linear Mode
