post to get the URL - for later use
post to get the URL - for later use
Solution1 fo this Thread
http://www.eileenslounge.com/viewtop...270792#p270792
Code:Sub VBAArrayTypeAlternativeToFilterInSegs_Solution1() ' http://www.eileenslounge.com/viewtopic.php?p=270915#p270915 .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238 Rem Make the two row indicie lists ( string of row indicies seperated witha space ) Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value Dim strSuc As String, strSpit As String Let strSuc = "7": Let strSpit = "7" Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then '///////// Let strSuc = strSuc & " " & Cnt Else Let strSpit = strSpit & " " & Cnt End If Next Cnt 'Debug.Print strSuc Rem Part A) modification (via string manipulation) Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1 For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34 Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings Next Cnt Debug.Print strSuc Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 ': Debug.Print strRws(Cnt - 1) Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms()) Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() ' ===================================================== Rem Part B) ' Header Worksheets("TempSht").Range("A7:X7").Copy Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype ' All formats in one go for each segmant from the temporary blue print worksheet Worksheets("TempSht").Range("A8:X41").Copy Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats ' ' Formulas Worksheets("TempSht").Range("A35:X41").Copy For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas ' Value = Worksheets("TempSht").Range("A35:X41").Formula ' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard Next Cnt ' Sorting For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False Next Cnt 'With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) '' Let .Value = arrOut() '.Sort key1:=Worksheets("consultant doctor").Range("C7"), Header:=True '.Font.Name = "Times New Roman" '.Font.Size = 13 '.Columns("D:X").NumberFormat = "0.00" '.EntireColumn.AutoFit 'End With ''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) ' Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare) ' ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) ' For Cnt = 1 To UBound(strRws(), 1) + 1 ' Let Rws(Cnt, 1) = strRws(Cnt - 1) ' Next Cnt ' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms()) 'With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) 'Let .Value = arrOut() ''.Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True '.Font.Name = "Times New Roman" '.Font.Size = 13 '.Columns("D:X").NumberFormat = "0.00" '.EntireColumn.AutoFit 'End With End Sub
post to get the URL - for later use
Solution for this post:
https://eileenslounge.com/viewtopic....271047#p271047
https://eileenslounge.com/viewtopic....271137#p271137
The main thing is
Sub DropItIn()
The first macro, Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() , which is the one that you run, is almost identical to the very first unmodified macro, Sub VBAArrayTypeAlternativeToFilter() ' https://eileenslounge.com/viewtopic....270792#p270792
Code:Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047 ' Main Data worksheet Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value ' Get row indicies for the two output worksheets Dim strSuc As String, strSpit As String Let strSuc = "7": Let strSpit = "7" Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then '///////// Let strSuc = strSuc & " " & Cnt Else Let strSpit = strSpit & " " & Cnt End If Next Cnt ' First output worksheet Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms()) With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) Let .Value = arrOut() .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit .Borders.LineStyle = xlContinuous End With ' Adding extra rows and stuff for Worksheets("consultant doctor") ================ ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted Call DropItIn(Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted ' second output worksheet 'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare) ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms()) With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) Let .Value = arrOut() .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit .Borders.LineStyle = xlContinuous End With ' Adding extra rows and stuff for Worksheets("Specialist Doctor") ================== ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted Call DropItIn(Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted End Sub
Macros for Solution 3 in this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic....271150#p271150
Code:Sub Solution3_2Workbooks() ' Rem 1 Worksheets info Dim WbM As Workbook, WbData As Workbook Set WbM = ThisWorkbook: Set WbData = Workbooks("Example.xlsx") ' Main Data worksheet Dim arrK() As Variant: Let arrK() = WbData.Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value ' Get row indicies for the two output worksheets Dim strSuc As String, strSpit As String Let strSuc = "7": Let strSpit = "7" Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then '///////// Let strSuc = strSuc & " " & Cnt Else Let strSpit = strSpit & " " & Cnt End If Next Cnt ' First output worksheet Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms()) With WbData.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) Let .Value = arrOut() .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit .Borders.LineStyle = xlContinuous End With ' Adding extra rows and stuff for Worksheets("consultant doctor") ================ ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted Call DropItIn3(WbData.Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted ' second output worksheet 'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare) ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms()) With WbData.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) Let .Value = arrOut() .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit .Borders.LineStyle = xlContinuous End With ' Adding extra rows and stuff for Worksheets("Specialist Doctor") ================== ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted Call DropItIn3(WbData.Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7) ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted End Sub ' Call ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted 'Worksheets("consultant doctor"), UBound(strRws(), 1) + 1 , 8 , 34 27, 7 ' 88 , 8 , 34 , 27 , 7 Sub DropItIn3(Ws As Worksheet, RwsCnt As Long, SttRw As Long, FstBkRw As Long, DtaRws As Long, ExtRws As Long) ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047 ' Header ThisWorkbook.Worksheets("TempSht").Range("A7:X7").Copy Ws.Range("A" & SttRw - 1 & ":X" & SttRw - 1 & "").PasteSpecial Paste:=xlPasteFormats ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype ' Insert extra rows ' Worksheets("TempSht").Range("A35:X41").Copy Dim Cnt As Long ' For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) - (DtaRws + ExtRws) Step DtaRws + ExtRws ' This misses the last section For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) Step DtaRws + ExtRws ThisWorkbook.Worksheets("TempSht").Range("A35:X41").Copy Ws.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Insert shift:=xlShiftDown ' Value = Worksheets("TempSht").Range("A35:X41").Formula ' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard Next Cnt End Sub
Macro for solution 4 for this Thread here
https://eileenslounge.com/viewtopic.php?f=30&t=34878
Post
https://eileenslounge.com/viewtopic....5c9974#p271181
Code:Sub VBAArrayTypeAlternativeToFilterSolution4() ' BY M. Doc.AElstein .......... https://eileenslounge.com/viewtopic.php?p=245238#p245238 ' Main Data worksheet Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value ' Get row indicies for the two output worksheets Dim strSuc As String, strSpit As String Let strSuc = "7": Let strSpit = "7" Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then '///////// Let strSuc = strSuc & " " & Cnt Else Let strSpit = strSpit & " " & Cnt End If Next Cnt Debug.Print strSuc ' First output worksheet Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) ' sorting with Arrays Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies Let strNms() = Application.Index(Worksheets("Main workbook").Cells, strRws(), 6) ' Array sort of Bubble sort, sort of Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop===================================== For rOuter = 2 To UBound(strNms) Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest If strNms(rOuter) > strNms(rInner) Then Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp Dim TempRs As String Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1 Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ==================End Outer Loop=============================================================== ' we must now re make strsuc Let strSuc = Join(strRws(), " ") Rem Part A) modification (via string manipulation) Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1 For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34 Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings Next Cnt Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Dim arrOut() As Variant Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms()) Let Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() Rem Part B) ' Header Worksheets("TempSht").Range("A7:X7").Copy Worksheets("consultant doctor").Range("A7:X7").PasteSpecial Paste:=xlPasteAll ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype ' All formats in one go for each segmant from the temporary blue print worksheet Worksheets("TempSht").Range("A8:X41").Copy Worksheets("consultant doctor").Range("A8:X" & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 & "").PasteSpecial Paste:=xlPasteFormats ' ' Formulas Worksheets("TempSht").Range("A35:X41").Copy For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).PasteSpecial Paste:=xlFormulas ' Value = Worksheets("TempSht").Range("A35:X41").Formula ' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard Next Cnt ''' Sorting NO LONGER NEEDED '' For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 '' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False '' Next Cnt ' With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) ' Let .Value = arrOut() ' .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True ' .Font.Name = "Times New Roman" ' .Font.Size = 13 ' .Columns("D:X").NumberFormat = "0.00" ' .EntireColumn.AutoFit ' End With '' second output worksheet ''Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) 'Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare) 'ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) ' For Cnt = 1 To UBound(strRws(), 1) + 1 ' Let Rws(Cnt, 1) = strRws(Cnt - 1) ' Next Cnt ' Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), Clms()) ' With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) ' Let .Value = arrOut() ' .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True ' .Font.Name = "Times New Roman" ' .Font.Size = 13 ' .Columns("D:X").NumberFormat = "0.00" ' .EntireColumn.AutoFit ' End With End Sub
Notes in support of this Thread
https://excelfox.com/forum/showthrea...ther-workbooks
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Worksheet: 1-Sheet1 6July
Row\Col A B C D E F G H I 1 Exchange Symbol Series/Expiry Open High Low Prev Close LTP 2 NSE ADANIENT EQ 151.85 165.45 151.4 151.85 152.35 25 3 NSE AMARAJABAT EQ 662.5 665.9 642.55 662.5 643.5 100
_____ Workbook: ap.xls ( Using Excel 2007 32 bit )
Worksheet: ap-Sheet1 6July
Row\Col A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 1 UserId AccountId EntityName Exchg-Seg Symbol Instrument Name Option Type NetBuyValue NetSellValue NetValue NetBuyQty NetSellQty NetQty BEP SellAvgPrice BuyAvgPrice LastTradedPrice MarkToMarket Realized MarkToMarket Unrealized MarkToMarket EL MarkToMarket Trading Symbol Client Context Series/Expiry Strike Price 2 WC5758 NSE AMBUJACEM EQ 10781.10 10878.30 97.20 54 54 201.45 199.65 201 97.2 97.2 97.2 AMBUJACEM-EQ EQ 3 WC5758 NSE ADANIENT EQ 420.60 430.50 9.90 2 2 215.25 210.30 210.35 9.9 9.9 9.9 ADANIENT-EQ EQ 25 4 WC5758 NSE SIEMENS EQ 2609.30 2642.50 33.20 2 2 1321.25 1304.65 1322.7 33.2 33.2 33.2 SIEMENS-EQ EQ 5 WC5758 NSE RBLBANK EQ 502.10 530.30 28.20 2 2 265.15 251.05 249.75 28.2 28.2 28.2 RBLBANK-EQ EQ 6 WC5758 NSE NATIONALUM EQ 1768.50 1782.00 13.50 54 54 33.00 32.75 32.75 13.5 13.5 13.5 NATIONALUM-EQ EQ 7 WC5758 NSE MARICO EQ 1688.40 1713.00 24.60 6 6 285.50 281.40 281.9 24.6 24.6 24.6 MARICO-EQ EQ 8 WC5758 NSE AMARAJABAT EQ 2429.10 2405.70 -23.40 18 133.65 134.95 135 -23.4 -23.4 -23.4 APOLLOTYRE-EQ EQ 100 9 WC5758 NSE L&TFH EQ 1765.80 1794.60 28.80 18 18 99.70 98.10 98.25 28.8 28.8 28.8 L&TFH-EQ EQ 10 WC5758 NSE ITC EQ 360.90 366.10 5.20 2 2 183.05 180.45 180.85 5.2 5.2 5.2 ITC-EQ EQ 11 WC5758 NSE INFRATEL EQ 10988.00 11180.70 192.70 54 54 207.05 203.48 203.8 192.7 192.7 192.7 INFRATEL-EQ EQ 12 WC5758 NSE DLF EQ 93069.00 94283.00 1214.00 486 486 194.00 191.50 190.3 1214 1214 1214 DLF-EQ EQ
If column I of 1.xls matches with column Z of ap.xls & column K of ap.xls is equals to column L of ap.xls Then
Look column H of 1.xls & if column H of 1.xls is greater than column D of 1.xls then it has to copy the first row of OrderFormat.xlsx & paste it to BasketOrder.xlsx
If column I of 1.xls matches with column Z of ap.xls & column K of ap.xls is equals to column L of ap.xls Then
Look column H of 1.xls & if column H of 1.xls is lower than column D of 1.xls then it has to copy the third row of OrderFormat.xlsx & paste it to BasketOrder.xlsx
_____ Workbook: OrderFormat.xlsx ( Using Excel 2007 32 bit )
Worksheet: Sheet1
Row\Col A B C D E F G H I J K L M N O P Q R S T U 1 NSE EQ NA NA NA 0 0 BUY MARKET NA CLI MIS DAY WC5758 NA 3 NA 2 NSE EQ NA NA NA 0 0 SELL SL-M CLI MIS DAY WC5758 NA NA NA 3 NSE EQ NA NA NA 0 0 SELL MARKET NA CLI MIS DAY WC5758 NA 3 NA 4 NSE EQ NA NA NA 0 0 BUY SL-M CLI MIS DAY WC5758 NA NA NA
Given BasketOrder
_____ Workbook: BasketOrder.xlsx Given by Avinash ( Using Excel 2007 32 bit )
Worksheet: Sheet1 6July
Row\Col NSE EQ NA NA NA BUY MARKET NA CLI MIS DAY WC5758 NA NA
For I of 25 in row 2 of 1.xls, we match with column z / row 3 in ap.xls
Column K and column L in ap.xls are both = 2 in row 3 in ap.xls So column K of ap.xls is equals to column L of ap.xls
Column H of row 2 in 1.xls is greater than column D of row 2 of 1.xls , so we copy the first row of of OrderFormat.xlsx & paste it to BasketOrder.xlsx
So I assume / geuss the given workbook, BasketOrder.xlsx is for After
Macro solution for this post:
https://excelfox.com/forum/showthrea...ther-workbooks
Code:' https://excelfox.com/forum/showthread.php/2569-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-two-other-workbooks ' Copy row from one workbook to another workbook based on conditions in two other workbooks Sub CopyRowFromWb4ToWb3basedOnConditionsInWb1AndWb2() Rem 1 worksheets range info Dim Wb1 As Workbook, Wb2 As Workbook, Wb3 As Workbook, Wb4 As Workbook Set Wb1 = Workbooks("1.xls") Set Wb2 = Workbooks("ap.xls") Set Wb3 = Workbooks("BasketOrder.xlsx") Set Wb4 = Workbooks("OrderFormat.xlsx") Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet, Ws4 As Worksheet Set Ws1 = Wb1.Worksheets.Item(1) Set Ws2 = Wb2.Worksheets.Item(1) Set Ws3 = Wb3.Worksheets.Item(1) Set Ws4 = Wb4.Worksheets.Item(1) Dim Lr1 As Long, Lr2 As Long, Lr3 As Long ', Lr4 As Long Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row Let Lr2 = Ws2.Range("D" & Ws2.Rows.Count & "").End(xlUp).Row Dim Rng1 As Range, Rng2 As Range ', Rng3 As Range, Rng4 As Range Set Rng1 = Ws1.Range("A1:I" & Lr1 & "") Set Rng2 = Ws2.Range("A1:Z" & Lr2 & "") '1b) data ranges for conditions Dim arr1() As Variant: Let arr1() = Rng1.Value2 Dim arr1I() As Variant: Let arr1I() = Rng1.Columns(9).Value2 Dim arr2() As Variant: Let arr2() = Rng2.Value2 Dim arr2Z() As Variant: Let arr2Z() = Rng2.Columns("Z").Value2 Rem 2 Do it Dim Cnt For Cnt = 2 To Lr1 Step 1 If arr1I(Cnt, 1) <> "" Then Dim MtchRes As Variant Let MtchRes = Application.Match(arr1I(Cnt, 1), arr2Z(), 0) If IsError(MtchRes) Then ' column I 1.xls value is not in column Z of ap.xls Else ' column I of 1.xls matches with column Z of ap.xls ' if column K of ap.xls is equals to column L of ap.xls If arr2(MtchRes, 11) = arr2(MtchRes, 12) Then ' If column H of 1.xls is greater than column D of 1.xls then If arr1(Cnt, 8) > arr1(Cnt, 4) Then 'copy the first row of OrderFormat.xlsx & paste it to BasketOrder.xlsx Let Ws3.Range("A1:U1").Value2 = Ws4.Range("A1:U1").Value2 ElseIf arr1(Cnt, 8) < arr1(Cnt, 4) Then ' If column H of 1.xls is less than column D of 1.xls then 'copy the third row of OrderFormat.xlsx & pate it to BasketOrder.xlsx Else Let Ws3.Range("A1:U1").Value2 = Ws4.Range("A3:U3").Value2 End If Else ' column K of ap.xls is not equal to column L of ap.xls End If End If Else ' empty column I in 1.xls End If Next Cnt End Sub
Macro for this post
https://eileenslounge.com/viewtopic....271237#p271237
https://eileenslounge.com/viewtopic....271255#p271255
Code:' https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237 Sub Solution5() ' https://eileenslounge.com/viewtopic.php?f=30&t=34878&p=271237#p271237 ' Main Data worksheet Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value ' Get row indicies for the two output worksheets Dim strSuc As String, strSpit As String Let strSuc = "7": Let strSpit = "7" Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then '///////// Let strSuc = strSuc & " " & Cnt Else Let strSpit = strSpit & " " & Cnt End If Next Cnt 'Debug.Print strSuc ' First half ## ' First output worksheet Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) ' sorting with Arrays Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6) ' Array sort of Bubble sort, sort of Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop===================================== For rOuter = 2 To UBound(strNms) Dim rInner As Long ' -------Inner Loop-------------"Right Hand"-------------------------- For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest If strNms(rOuter) > strNms(rInner) Then Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp Dim TempRs As String Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1 Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ==================End Outer Loop=============================================================== ' we must now re make strsuc Let strSuc = Join(strRws(), " ") Rem Part A) modification (via string manipulation) Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1 For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34 Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings Next Cnt Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt Dim arrOut() As Variant Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms()) Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() 'Second half worksheet Consultant doctor ' Main formatting With ThisWorkbook.Worksheets("Consultant doctor").UsedRange .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit End With ' For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' Most borders Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous ' Sum formulas Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" Let ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total" Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total" Next Cnt ' First half## ' Second output worksheet Specialist Doctor 'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46) 'Dim strRws() As String Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare) ' sorting with Arrays 'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6) ' Array sort of Bubble sort, sort of 'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop===================================== For rOuter = 2 To UBound(strNms) ' Dim rInner As Long ' -------Inner Loop------------"Right Hand"-------------------------- For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest If strNms(rOuter) > strNms(rInner) Then ' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp ' Dim TempRs As String Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1 Else End If Next rInner ' ----------------------------------------------------------------------- Next rOuter ' ==================End Outer Loop=============================================================== ' we must now re make strsuc Let strSpit = Join(strRws(), " ") Rem Part A) modification (via string manipulation) 'Dim TotRws As Long Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies 'Dim Segs As Long Let Segs = Int(TotRws / 27) + 1 For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34 Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings Next Cnt Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare) 'Dim Rws() As String ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1) For Cnt = 1 To UBound(strRws(), 1) + 1 Let Rws(Cnt, 1) = strRws(Cnt - 1) Next Cnt 'Dim arrOut() As Variant Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms()) Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() 'Second half worksheet Specialist Doctor ' Main formatting With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit End With ' For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' Most borders Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(27, 24).Borders.LineStyle = xlContinuous ' Sum formulas Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" Let ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 1 & "").Value = "The total" Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 7 & "").Value = "Previous total" Next Cnt End Sub
Noptes in support of answer for this Post:
https://excelfox.com/forum/showthrea...ll=1#post14591
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )
Worksheet: 1-Sheet1 13July
Row\Col Exchange Symbol Series/Expiry Open High Low Prev Close LTP Wrong results NSE ACC EQ BUY <--Ws1 NSE ADANIENT EQ BUY NSE ADANIPORTS EQ BUY output wanted in K of 1.xls which is Ws1 D E F G H I J K L Exchange Symbol Series/Expiry Open High Low Prev Close LTP wanted results NSE ACC EQ BUY NSE ADANIENT EQ BUY NSE ADANIPORTS EQ BUY Ws2 - AlertCodes.xlsx B C D E F G H I J K L NSE < A GTT NSE < A GTT NSE < A GTT
Posting Permissions
Reply With Quote
Bookmarks