Just testing links to Threads
( This post is https://excelfox.com/forum/showthrea...ge30#post13349 )
Originally Posted by DocAElstein
See here ( This post https://excelfox.com/forum/showthrea...ge30#post13349 )
for typical comparisons of text Files, Excel files, and data files
Text File: https://excelfox.com/forum/showthrea...ll=1#post13693
Excel File: https://excelfox.com/forum/showthrea...ll=1#post13694
Data File: https://excelfox.com/forum/showthrea...ll=1#post13695
In support of this thread answer
https://excelfox.com/forum/showthrea...rt-Csv-To-Xlsx
Code:' https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx 'XLFlNme is the Excel File name wanted for the new File 'TxtFlNme is Text File name of an existing text file 'valSep is the values separator used in the existing text file 'LineSep is the line separator used in thee existing text file 'Paf it the path to the files. ( I assume they are at the same place for the existing text file and the new Excel File ) Function MakeXLFileusingvaluesInTextFile(ByVal Paf As String, ByVal TxtFlNme As String, ByVal XLFlNme As String, ByVal valSep As String, ByVal LineSep As String) Rem 2 Text file info ' 2a) get the text file as a long single string Dim FileNum As Long: Let FileNum = FreeFile(1) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function Dim PathAndFileName As String, TotalFile As String Let PathAndFileName = Paf & Application.PathSeparator & TxtFlNme ' CHANGE TO SUIT From vixer zyxw1234 : http://www.eileenslounge.com/viewtopic.php?f=30&t=34629 DF.txt https://app.box.com/s/gw941dh9v8sqhvzin3lo9rfc67fjsbic Open PathAndFileName For Binary As #FileNum 'Open Route to data. Binary is a fundemental type data input... TotalFile = Space(LOF(FileNum)) '....and wot recives it has to be a string of exactly the right length Get #FileNum, , TotalFile Close #FileNum ' 2b) Split into wholes line _ splitting the text file into rows by splitting by Line Seperator Dim arrRws() As String: Let arrRws() = Split(TotalFile, LineSep, -1, vbBinaryCompare) Dim RwCnt As Long: Let RwCnt = UBound(arrRws()) + 1 ' +1 is nedeed as the Split Function returns indicies 0 1 2 3 4 5 etc... ' 2c) split first line to determine the Field(column) number Dim arrClms() As String: Let arrClms() = Split(arrRws(0), valSep, -1, vbBinaryCompare) Dim ClmCnt As Long: Let ClmCnt = UBound(arrClms()) + 1 ' 2d) we can now make an array for all the rows, and columns Dim arrOut() As String: ReDim arrOut(1 To RwCnt, 1 To ClmCnt) Rem 3 An array is built up by _.... Dim Cnt As Long For Cnt = 1 To RwCnt ' _.. considering each row of data 'Dim arrClms() As String Let arrClms() = Split(arrRws(Cnt - 1), ",", -1, vbBinaryCompare) ' ___.. splitting each row into columns by splitting by the comma Dim Clm As Long ' For Clm = 1 To UBound(arrClms()) + 1 Let arrOut(Cnt, Clm) = arrClms(Clm - 1) Next Clm Next Cnt Rem 4 Finally the array is pasted to a worksheet in a new file Workbooks.Add ActiveWorkbook.SaveAs Filename:=Paf & Application.PathSeparator & XLFlNme, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Workbooks("" & XLFlNme & "").Worksheets.Item(1).Range("A1").Resize(RwCnt, ClmCnt).Value = arrOut() End Function
In support of the answer to these forum Thread posts
https://www.excelforum.com/excel-pro...een-files.html
https://excelfox.com/forum/showthrea...ll=1#post14130
Code:' https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html#post5353174 Sub karmapala() 'Dim arr() As Variant Dim Wb1 As Workbook, Wb2 As Workbook, Sh1 As Worksheet, Sh2 As Worksheet Set Wb1 = Workbooks("1.xls") Set Sh1 = Wb1.Worksheets.Item(1) ' Wb1.Sheets("1-Sheet1") Dim Rng As Range ' For main data range in 1.xls ' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Rows.Count).End(xlUp)) ' This and the next line will error if macro.xlsm is active when the macro is run as Rows.Count will give a much larger number ( 1048576 ) than there are rows in a pre Excel 2007 worksheet ( . ' Set Rng = Sh1.Range(Sh1.Range("D2"), Sh1.Range("D" & Rows.Count).End(xlUp))' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Sh1.Rows.Count).End(xlUp)) Set Wb2 = Workbooks("macro.xlsm") ' Workbooks("Macro.xlsm") Set Sh2 = Wb2.Worksheets.Item(1) ' Wb2.Sheets("Sheet1") Dim X As Long X = 0 Rem 2 In this section we build an array, arr(), of column I values to be ... match Column I of 1.xls with column B of macro.xlsm Dim Cel As Range For Each Cel In Rng Dim arr() As Variant ' This will become the array of column I values to be ... match Column I of 1.xls with column B of macro.xlsm If Cel.Value = Cel.Offset(0, 1).Value And Cel.Value <> Cel.Offset(0, 2).Value Then ' If column D of 1.xls is equal to Column E of 1.xls & column D of 1.xls is not equal to column F of 1.xls Then ... ReDim Preserve arr(X) arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm X = X + 1 ' to make the array element for the next entry, should there be one End If 'If Cel.Value <> Cel.Offset(0, 1) And Cel.Value = Cel.Offset(0, 2) Then If Cel.Value = Cel.Offset(0, 2) And Cel.Value <> Cel.Offset(0, 1) Then ' ... ReDim Preserve arr(X) ReDim Preserve arr(X) arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm X = X + 1 ' to make the array element for the next entry, should there be one End If Next If X = 0 Then Exit Sub Rem 3 In this section we take each of the values in column I of 1.xls meeting the criteria - ... match Column I of 1.xls with column B of macro.xlsm Dim El For Each El In arr() ' arr take each value in column I meeting the criteria - and look for the match in a row in column B of macro.xlsm Dim B As Range ' The matched cell in column B in macro.xlsm Set B = Sh2.Range("B:B").Find(El, lookat:=xlWhole) ' Look for the matched cell in macro.xlsm If Not B Is Nothing Then Dim FirstAddress As String: FirstAddress = B.Address ' The first match address to check when the VBA .Find Methos starts again Do If B.Offset(0, 1).Value = "" Then B.Offset(0, 1).Value = 1 ' row of match has remark 1 in column C Else B.End(xlToRight).Offset(0, 1).Value = B.End(xlToRight).Value + 1 End If Set B = Sh2.Range("B:B").FindNext(B) ' Look for the Next matched cell in macro.xlsm Loop While B.Address <> FirstAddress ' check when the VBA .Find Methos starts again End If Next End Sub
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
Posting Permissions
Reply With Quote
Bookmarks