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