Appendix Thread. App Index Rws() Clms() Majic code line Codings for other Threads, Tables etc.)

Just testing links to Threads

( This post is https://excelfox.com/forum/showthrea...ge30#post13349 )

Quote:

Originally Posted by DocAElstein

Some notes related to these posts

https://excelfox.com/forum/showthrea...rt-Csv-To-Xlsx https://excelfox.com/forum/showthrea...ll=1#post13318
http://www.eileenslounge.com/viewtopic.php?f=30&t=34610
http://www.eileenslounge.com/viewtop...267706#p267706
http://www.eileenslounge.com/viewtop...269104#p269104
http://www.eileenslounge.com/viewtopic.php?f=30&t=34638
https://chandoo.org/forum/threads/fe...2/#post-264364

Later

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 2

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

Solution 3

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

Solution 4

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 )

_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

Worksheet: 1-Sheet1 6July

_____ Workbook: ap.xls ( Using Excel 2007 32 bit )

_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

Worksheet: ap-Sheet1 6July

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 )

_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

Worksheet: Sheet1

Given BasketOrder
_____ Workbook: BasketOrder.xlsx Given by Avinash ( Using Excel 2007 32 bit )

_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

Worksheet: Sheet1 6July

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

_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

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 )

_Row\^Col
A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP Wrong results

2
NSE ACC EQ
1265

1282.7

1246.5

1275.3

1247

22
BUY
202
<--Ws1

3
NSE ADANIENT EQ
151.85

165.45

151.4

151.85

152.35

25
BUY
303

4
NSE ADANIPORTS EQ
348

348

338.5

346.55

338.85

15083
BUY
0

5

6
output wanted in K of 1.xls which is Ws1 D E F G H I J K L

7

1
Exchange Symbol Series/Expiry Open High Low Prev Close LTP wanted results

8

2
NSE ACC EQ
1265

1282.7

1246.5

1275.3

1247

22
BUY
101

9

3
NSE ADANIENT EQ
151.85

165.45

151.4

151.85

152.35

25
BUY
202

10

4
NSE ADANIPORTS EQ
348

348

338.5

346.55

338.85

15083
BUY
303

11

5

12

13

14

15
Ws2 - AlertCodes.xlsx B C D E F G H I J K L

16

1
NSE
22

6
<
100
A GTT

17

2
NSE
25

6
<
200
A GTT

18

3
NSE
15083

6
<
300
A GTT

19

4

Worksheet: 1-Sheet1 13July

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP			Wrong results
2	NSE	ACC	EQ	1265	1282.7	1246.5	1275.3	1247	22	BUY	202		<--Ws1
3	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25	BUY	303
4	NSE	ADANIPORTS	EQ	348	348	338.5	346.55	338.85	15083	BUY	0
5
6			output wanted in K of 1.xls which is Ws1				D	E	F	G	H	I	J	K	L
7			1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP			wanted results
8			2	NSE	ACC	EQ	1265	1282.7	1246.5	1275.3	1247	22	BUY	101
9			3	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25	BUY	202
10			4	NSE	ADANIPORTS	EQ	348	348	338.5	346.55	338.85	15083	BUY	303
11			5
12
13
14
15		Ws2 - AlertCodes.xlsx		B	C	D	E	F	G	H	I	J	K	L
16		1	NSE	22	6	<	100	A					GTT
17		2	NSE	25	6	<	200	A					GTT
18		3	NSE	15083	6	<	300	A					GTT
19		4

Macro for last post, and also for anser to this Thread post:
https://excelfox.com/forum/showthrea...ll=1#post14578
https://excelfox.com/forum/showthrea...ll=1#post14591
https://www.excelforum.com/excel-pro...n-matches.html
https://excelfox.com/forum/showthrea...ll=1#post14588
https://eileenslounge.com/viewtopic.php?f=30&t=34936

Code:

' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578 https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578 ' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591 Sub STEP6() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim Wb1 As Workbook, Wb2 As Workbook Dim R2 As Long, Lr As Long, I As Long ' r2&, lr&, i& Set Wb1 = Workbooks("1.xls") ' For open workbook Alternatively to open worknok - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") Set Ws1 = Wb1.Worksheets.Item(1) Set Wb2 = Workbooks("AlertCodes.xlsx") ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xlsx") Set Ws2 = Wb2.Worksheets.Item(4) With Ws1 Let Lr = .Cells(.Rows.Count, "A").End(xlUp).Row For I = 2 To Lr ' Reset r2 R2 = 0 ' Avoid error messages On Error Resume Next ' Try to get r2 R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0) ' R2 returns the matched row if there is a match ' Restore error handling On Error GoTo 0 ' Only set column K if r2 is valid If R2 > 0 Then If Ws2.Cells(R2, "D") = ">" Then .Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value ' Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value Else .Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value ' Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value End If End If Next I End With Wb1.Save Wb1.Close Wb2.Close End Sub

test post to get URL for later use

Alternative solution to Step6()
( https://excelfox.com/forum/showthrea...ll=1#post14594 )

The main changes are
_1) I use arrays. ( arr1() , arr2() , arr2B() )
I do this just from personal choice. I do this because arrays work much faster if you are only interested in values with no cell formatting
_2) I changed WorksheetFunction.Match to Application.Match , because I do not like to use On Error Resume Next
I do not need On Error Resume Next for Application.Match , because , if it does not find a match, it does not error. Instead, it returns a VBA error string message, which can be tested for using IsError( __ )
_2) I do not use _ With _ End With _ because it confuses me

I left the original code lines in , ' commented out for comparison

Code:

' https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342720 https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342598 ' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578 https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578 ' https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591 Sub STEP6Alternative() Rem 1 Worksheets data info Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet Dim I As Long, Lr As Long ' R2 As Long, Lr As Long, I As Long ' r2&, lr&, i& Set Wb1 = Workbooks("1.xls") ' For open workbook Alternatively to open workbook - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls") Set Ws1 = Wb1.Worksheets.Item(1) Set Wb2 = Workbooks("AlertCodes.xlsx") ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xlsx") Set Ws2 = Wb2.Worksheets.Item(4) ' With Ws1 Let Lr = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row Dim arr1() As Variant Let arr1() = Ws1.Range("A1:K" & Lr & "").Value2 Dim lr2 As Long ' https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=14565&viewfull=1#post14565 Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467 Let lr2 = Ws2.Cells(Ws2.Rows.Count, "B").End(xlUp).Row ' This is the column to be serached in Dim arr2B() As Variant Let arr2B() = Ws2.Range("B1:B" & lr2 & "").Value2 Dim arr2() As Variant Let arr2() = Ws2.Range("A1:K" & lr2 & "").Value2 Rem We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2. For I = 2 To Lr ' We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2. ' Reset r2 R2 = 0 ' Avoid error messages On Error Resume Next ' Try to get r2 Values in column I of 1.xls ( first worksheet), starting at row 2, are to be looked for, ( Matched ) in column B of AlertCodes.xlsx ( 4th worksheet ) 'R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0) ' R2 returns the matched row if there is a match Dim R2 As Variant ' We need a variant so that both a Long Number or a VB error can be held in it, which are the two possible return types with Application.Match https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14204&viewfull=1#post14204 Let R2 = Application.Match(arr1(I, 9), arr2B(), 0) ' Ws1.Cells(I, "I").Value is arr1(I, 9) ' Restore error handling On Error GoTo 0 ' Only set column K if r2 is valid, so only if a match was found, so only if R" is Not a VBA error If Not IsError(R2) Then ' If R2 > 0 Then 'If Ws2.Cells(R2, "D") = ">" Then ' Ws2.Cells(R2, "D").Value is arr2(R2, 4) If arr2(R2, 4) = ">" Then ' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value ' This was wrong: Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value arr1(I, 11) = arr2(R2, 5) - 0.01 * arr2(R2, 5) 'Else ElseIf arr2(R2, 4) = "<" Then ' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value ' This was wrong: Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value arr1(I, 11) = arr2(R2, 5) + 0.01 * arr2(R2, 5) Else ' we dont have a "<" or a ">" Do Nothing End If End If Next I ' End With 'Rem Option to save and/ or close files Wb1.Save Wb1.Close Wb2.Close End Sub

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub Ha2a() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006 Rem 1 worksheets data info Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467 Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ## Rem 2 Outer loop Do ing While data is still there in column A Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A Do ' ========================================================== Main Outel loop for unique name section== Rem 3 Inner Loop for a section of names ' --------------------------------------------------------------- Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed Do '3a) get the row indicies for this section Let CntIn = CntIn + 1 Let strRws = strRws & " " & CntIn Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section --- '3b) start doing stuff for each unique name '3b(i) The workbook with unique name Workbooks.Add Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme ' Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1) '3b(ii) The "vertical" array of row indicies required for "magic code line" Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws() ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0 Dim Cnt As Long For Cnt = 1 To UBound(Rws()) + 1 Let RwsT(Cnt, 1) = Rws(Cnt - 1) Next Cnt '3b(iii) The "magic code line" Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation '3b(iv) Output to first worksheet in workbook and close and save it Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut() Workbooks(WbNme).Close Savechanges:=True '3b(v) Some tidying up before we possibly go to the next unique name Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name Loop While CntIn < Lr ' ======================================================================================================= End Sub ' Simplified version Sub Ha2a_() Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2 Dim CntIn As Long: Let CntIn = 1 Do Dim strRws As String: Let strRws = "1" Do Let CntIn = CntIn + 1 Let strRws = strRws & " " & CntIn Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) Workbooks.Add ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx" Dim Rws() As String: Let Rws() = Split(strRws) Dim RwsT() As String ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) Dim Cnt As Long For Cnt = 1 To UBound(Rws()) + 1 Let RwsT(Cnt, 1) = Rws(Cnt - 1) Next Cnt Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3)) Let Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True Let strRws = "1" Loop While CntIn < Lr End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic....245238#p245238

Ref

Full macro version for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub Ha2b() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006 Rem 1 worksheets data info Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row ' Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467 Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2 ' The only data needed to ba considered is column A. The "magic code line" will be used to get all our results in one go I need +1 to use an empty line in determining when the last name in the list has something different after it ## Rem 2 Outer loop Do ing While data is still there in column A Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A Dim strTRw As Long: Let strTRw = 2 ' We are wanting to determine the start and stop row of a grouped names section. The first one will be at row 2 Do ' ========================================================== Main Outel loop for unique name section== Rem 3 Inner Loop for a section of names ' --------------------------------------------------------------- Do '3a) get the row indicies for this section Let CntIn = CntIn + 1 Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section --- '3b) start doing stuff for each unique name '3b(i) The workbook with unique name Workbooks.Add Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme ' Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1) '3b(ii) The "vertical" array of row indicies required for "magic code line" Dim StpRw As Long: Let StpRw = CntIn ' this is the last row for a group of names Dim RwsT() As Variant ' I need Variant because the Evaluate(" ") methond below returns its field of values in housed in Variant type elements Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")") '3b(iii) The "magic code line" Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation '3b(iv) Output to first worksheet in workbook and close and save it 'Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut() Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' I am missing the Header row so start at top left A2 to leave space for the Header WsM.Range("A1:C1").Copy ' Header row Ws.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme Workbooks(WbNme).Close Savechanges:=True '3b(v) Some tidying up before we possibly go to the next unique name Let strTRw = CntIn + 1 ' I assume the next row is the next name Loop While CntIn < LrM ' ======================================================================================================= End Sub ' simplified version Sub Ha2b_() Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2 Dim CntIn As Long: Let CntIn = 1 Dim strTRw As Long: Let strTRw = 2 Do Do Let CntIn = CntIn + 1 Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) Workbooks.Add ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx" Dim Ws As Worksheet: Set Ws = Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1) Dim StpRw As Long: Let StpRw = CntIn Dim RwsT() As Variant Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")") Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3)) Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() WsM.Range("A1:C1").Copy Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True Let strTRw = CntIn + 1 Loop While CntIn < LrM End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic....245238#p245238

Ref

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub DaDoRunRonDeDo2() ' https://eileenslounge.com/viewtopic.php?f=27&t=35006 Rem 1 worksheets data info Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) ' First worksheet counting tabs from the left Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2 Rem 2 obtain unique values from column A ' 2a) A single string containing the unique names Dim Cnt As Long For Cnt = 2 To Lr Step 1 Dim strUnics As String If InStr(1, strUnics, arrA(Cnt, 1), vbBinaryCompare) = 0 Then Let strUnics = strUnics & arrA(Cnt, 1) & " " Else ' we already had that name in the string End If Next Cnt Let strUnics = Left(strUnics, (Len(strUnics) - 1)) ' Take off last space ' 2b) A 1 dimansional array of the unique names Dim arrUnics() As String: Let arrUnics() = Split(strUnics, " ", -1, vbBinaryCompare) Rem 3 Do it for each unique name Dim WbCnt As Long: Let WbCnt = UBound(arrUnics()) + 1 ' +1 is needed because Split function returns an array starting at indicia 0 For WbCnt = 1 To WbCnt ' Main outer Loop ======================================== ' 3a) Get our indicies for the rows wanted of our current name Dim strRws As String: Let strRws = "1" ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed For Cnt = 2 To Lr Step 1 If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then Let strRws = strRws & " " & Cnt Else ' The name is not one of the current name being considered End If Next Cnt '3b) start doing stuff for each unique name '3b(i) The workbook with unique name Workbooks.Add Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx" ' The current last unique name will be the new Workbook name ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme ' Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1) '3b(ii) The "vertical" array of row indicies required for "magic code line" Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the ReDim method below allows us to make the sizing dynamic based on the size of Rws() ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The +1 comes in because the Split function returns a 1D array starting at indicia 0 For Cnt = 1 To UBound(Rws()) + 1 Let RwsT(Cnt, 1) = Rws(Cnt - 1) Next Cnt '3b(iii) The "magic code line" Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)") ' ** CHANGE TO SUIT ** This is currently for columns A B C 1 2 3 For non consequtive columns you can use like Array("1", "3", "26") - that last example gives in the new range just columns A C Z from the original worksheet Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line --- ' "Magic code line" http://www.eileenslounge.com/viewtopic.php?p=265384#p265384 http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384 See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172 , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp for full explanation '3b(iv) Output to first worksheet in workbook and close and save it Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut() Workbooks(WbNme).Close Savechanges:=True '3b(v) Some tidying up before we possibly go to the next unique name Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name Next WbCnt ' ===================================================================== End Sub ' simplified version Sub DaDoRunRonDeDo2_() Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2 Dim Cnt As Long For Cnt = 2 To Lr Step 1 Dim strUnics As String If InStr(strUnics, arrA(Cnt, 1)) = 0 Then strUnics = strUnics & arrA(Cnt, 1) & " " Next Cnt Dim arrUnics() As String: Let arrUnics() = Split(Trim(strUnics)) Dim WbCnt As Long For WbCnt = 1 To UBound(arrUnics()) + 1 Dim strRws As String: Let strRws = "1" For Cnt = 2 To Lr Step 1 If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then strRws = strRws & " " & Cnt Next Cnt Workbooks.Add Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx" ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrUnics(WbCnt - 1) & ".xlsx" Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) Dim RwsT() As String ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) For Cnt = 1 To UBound(Rws()) + 1 Let RwsT(Cnt, 1) = Rws(Cnt - 1) Next Cnt Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3)) Let Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Close Savechanges:=True Let strRws = "1" Next WbCnt End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic....245238#p245238

Post for later use
Required to get URL now

In support of this Thread post
https://www.excelforum.com/excel-pro...ml#post5397531

Option Explicit and variable declaration
Hello
You can easily find lots of information on the internet that can explain Option Explicit , ( just a few examples given in the Refs below). But my take on it for you:
The simple answer to your specific question is that its not necessary, its just personal choice.
It’s all related to the issue of declaring variables – its difficult to discuss the issue of Option Explicit without discussing the variable declaration issue: In VBA it is not necessary to declare variables. If you use a variable, without an initial declaration, then it will be created “on the fly” as you use them. Mostly they will then be given the Variant type
What a code line at the top of a code module, of Option Explicit , does, is enable the option of being explicit for variable declaration. In other words, it forces you to declare all your variables: If you have this code line at the top of your code module, but then in any coding don’t declare any variable, you will get a warning error, on attempting to run your macro.

Simple Examples
Lets say you make a simple Typo, and write MyMsg , when you meant MyMsig. The following macro won’t error, but it wont give the answer you may have expected.
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/WwnXByf.jpg
There’s nufin there in that Message Box! – Why? – The message box is using variable MyMsg: The variables MyMsig and MyMsg were created “on the fly”, as you used them, but MyMsg has not been used yet. There is no error, but you did not get to be warned of your likely typo of writing MyMsg instead of MyMsig

The next 2 macros would warn you of undeclared variables with a compile error on attempting to run them
Option Explicit
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/LlXPOfj.jpg
That last macro did not catch your Typo, but if you corrected that missing declaration for MyMsig, then you would still go on to get the warning of the non declared MyMsg
Option Explicit
Sub Testit()
Dim MyMsig As String
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub
https://i.imgur.com/D9KsQuG.jpg
In fact, in the last macro you would have had the possibility to notice your mistake whilst writing the code line
MsgBox Prompt:=mymsg , provided that you had written it in lower case:
If you had written it just like that, lowercase, mymsg, - having done that, then mymsg would have stayed lowercase when you moved on to writing the next line. On the other hand, If any variable had been declared using any Uppercase characters, then on writing that variable name in lower case characters, and then moving on to the next line, that previous code line would have been changed automatically by the VB Editor to show the correct variable word, including any capital characters.
So an additional point from that experiment is that, if you do choose to declare your variables, then its worth considering using at least one capital in your variable name, but then going on when writing the variable further in the macro to use just lower case always. The VB Editor should automatically correct all your variables, ( and incidentally also correct any commands you type in lower case ) to their correct form including any upper case characters: So, if something remains lower case when you move on to writing the next code line, then you have an immediate indication that something is probably wrong, ( mostly*** ).
( The automatic capitalisation is not directly related to using Option Explicit, but is related to the issue of declaring variables. The use of Option Explicit is mostly of consideration when considering how you choose to handle your variable usage).

So you have a couple of good reason to choose to use Option Explicit and declare your variables carefully.

But you do not have to use Option Explicit
Most people prefer to declare all variables, and to use Option Explicit
There are some people , amongst them respected professionals who go against the trend, don’t use Option Explicit, and consider the use of declaration only where really needed, for example when working when working with class modules. The reasoning is usually given as to avoid redundancy in coding, keeping coding as efficient as possible.

Its personal choice. Do anyfin ya wanna do :)

Molly

Ref:
http://www.eileenslounge.com/viewtop...265556#p265556

http://www.eileenslounge.com/viewtopic.php?f=30&t=2281

*** Unfortunately life is not so simple with Microsoft. A bug can cause the automatic capitalization to fail. If you notice this, for example when known commands stay lowercase, then the only known cure seems to be to restart Excel and/ or your computer.

1 Attachment(s)

In support of this Thread:
http://www.eileenslounge.com/viewtop...271368#p271368

Code:

For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' Most borders Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 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" ' HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "") Next Cnt

Code:

Sub Solution6() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095 ' 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 stage 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(-27, 0).Resize(29, 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" ' HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "") Next Cnt ' First half## ' Second stage 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(-27, 0).Resize(29, 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" ' HPageBreaks.Add ThisWorkbook.Worksheets("Specialist Doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "") Next Cnt End Sub

1 Attachment(s)

In support of this Thread:
http://www.eileenslounge.com/viewtop...271368#p271368

Code:

Sub Solution7() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095 ' 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 stage 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 With ThisWorkbook.Worksheets("consultant doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True .Range("A" & Cnt + 1 & "").Value = "The total" .Range("A" & Cnt + 7 & "").Value = "Previous total" ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("consultant doctor") Next Cnt ' First half## ' Second stage 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 With ThisWorkbook.Worksheets("Specialist Doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True .Range("A" & Cnt + 1 & "").Value = "The total" .Range("A" & Cnt + 7 & "").Value = "Previous total" ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("Specialist Doctor") Next Cnt End Sub

In support of this Thread:
http://www.eileenslounge.com/viewtop...271368#p271368

Code:

'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 With ThisWorkbook.Worksheets("consultant doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True .Range("A" & Cnt + 1 & "").Value = "The total" .Range("A" & Cnt + 7 & "").Value = "Previous total" ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("consultant doctor") Next Cnt

Code:

'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 With ThisWorkbook.Worksheets("Specialist Doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True .Range("A" & Cnt + 1 & "").Value = "The total" .Range("A" & Cnt + 7 & "").Value = "Previous total" ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("Specialist Doctor") Next Cnt

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989

Code:

Sub Solution8() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095 ' 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 stage 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 ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row ' 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 With ThisWorkbook.Worksheets("consultant doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True ' .Range("A" & Cnt + 1 & "").Value = "The total" .Range("A" & Cnt + 7 & "").Value = "Previous total" ' row height for "Total" and "previous total" .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50 .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 ' ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("consultant doctor") Next Cnt ' First half## ' Second stage 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 ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row ' 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 With ThisWorkbook.Worksheets("Specialist Doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True ' .Range("A" & Cnt + 1 & "").Value = "The total" .Range("A" & Cnt + 7 & "").Value = "Previous total" ' row height for "Total" and "previous total" .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50 .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 ' ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("Specialist Doctor") Next Cnt End Sub

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989
Part 1 of 3

Code:

Sub Solution8b() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095 ' 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" ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then '///////// Let strSuc = strSuc & " " & Cnt ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove Else Let strSpit = strSpit & " " & Cnt End If Next Cnt 'Debug.Print strSuc

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989

part 2 of 3

Code:

' First half ## ' First stage 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 ' I need my array to be like 137 rather than like 109 strRws() is 0 To 108 , ' 137 is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 ' Missing is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) ' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it Dim LstEmptyRws As Long: Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) Let strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare) ' Stop 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 RwsT() As Variant, ClmsT() As Variant Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 ..... Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 ..... Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT()) Dim arrOut() As Variant ' This is the main output, all in one go. But we can put some values into the array before... Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms()) ' ... we can put some values (words) and formulas into the array before we paste it out For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before... Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7 Let arrOut(Cnt + 7 - 6, 1) = "Previous total" Dim Cl As Long ' formulas For Cl = 4 To 24 ' D To X Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' .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 arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" Next Cl ' First signature Second signature third signature Fourth signature Fifth signature ' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") Let arrOut(Cnt + 2 - 6, 2) = "First signature" Let arrOut(Cnt + 2 - 6, 7) = "Second signature" Let arrOut(Cnt + 2 - 6, 12) = "Third signature" Let arrOut(Cnt + 2 - 6, 17) = "Forth signature" Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature" ' Let arrOut(Cnt + 2 - 6, 2) = "First signature" ' Let arrOut(Cnt + 2 - 6, 2) = "First signature" Next Cnt ' Main paste out of all data and some words and formulas Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() 'Second half worksheet Consultant doctor ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row ' 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 With ThisWorkbook.Worksheets("consultant doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas ' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature ' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True ' ' .Range("A" & Cnt + 1 & "").Value = "The total" ' .Range("A" & Cnt + 7 & "").Value = "Previous total" ' row height for "Total" and "previous total" .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50 .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 ' ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("consultant doctor") Next Cnt ' delete last unwanted Previous Total row ThisWorkbook.Worksheets("consultant doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...." ' End first stage worksheet___________________________________________________________________________________________ '

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989

part 3 of 3

Code:

' ' First half## ' Second stage 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) ' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it 'Dim LstEmptyRws As Long Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) Let strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove 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 RwsT() As Variant, ClmsT() As Variant Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 ..... Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 ..... Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT()) 'Dim arrOut() As Variant Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms()) ' ... we can put some values (words) and formulas into the array before we paste it out For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before... Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7 Let arrOut(Cnt + 7 - 6, 1) = "Previous total" 'Dim Cl As Long ' formulas For Cl = 4 To 24 ' D To X Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' .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 arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" Next Cl ' First signature Second signature third signature Fourth signature Fifth signature ' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") Let arrOut(Cnt + 2 - 6, 2) = "First signature" Let arrOut(Cnt + 2 - 6, 7) = "Second signature" Let arrOut(Cnt + 2 - 6, 12) = "Third signature" Let arrOut(Cnt + 2 - 6, 17) = "Forth signature" Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature" ' Let arrOut(Cnt + 2 - 6, 2) = "First signature" ' Let arrOut(Cnt + 2 - 6, 2) = "First signature" Next Cnt ' Main paste out of all data and some words and formulas Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() 'Second half worksheet Specialist Doctor ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row ' 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 With ThisWorkbook.Worksheets("Specialist Doctor") ' Most borders .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous ' Sum formulas ' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C" ' First signature Second signature third signature Fourth signature Fifth signature ' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "") ' Bold stuff .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True ' ' .Range("A" & Cnt + 1 & "").Value = "The total" ' .Range("A" & Cnt + 7 & "").Value = "Previous total" ' row height for "Total" and "previous total" .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50 .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 ' ' HPageBreaks.Add .HPageBreaks.Add .Range("A" & Cnt + 7 & "") End With ' ThisWorkbook.Worksheets("Specialist Doctor") Next Cnt ' delete last unwanted Previous Total row ThisWorkbook.Worksheets("Specialist Doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...." ' End Sub

In support of this Post
https://eileenslounge.com/viewtopic....273285#p273285

Code:

Sub Solution9ProObfuscation() Application.ScreenUpdating = False Dim arrK() As Variant: arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value Dim strSuc As String, strSpit As String strSuc = "7": strSpit = "7" Dim Cnt As Long For Cnt = 11 To UBound(arrK(), 1) If arrK(Cnt, 1) = "Positive" Then strSuc = strSuc & " " & Cnt Else strSpit = strSpit & " " & Cnt End If Next Cnt Dim Clms() As Variant: 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: strRws() = Split(strSuc) Dim strNms() As Variant: strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6) Dim rOuter As Long For rOuter = 2 To UBound(strNms) Dim rInner As Long For rInner = rOuter + 1 To UBound(strNms) If strNms(rOuter) > strNms(rInner) Then Dim varTemp As Variant varTemp = strNms(rOuter): strNms(rOuter) = strNms(rInner): strNms(rInner) = varTemp Dim TempRs As String TempRs = strRws(rOuter - 1): strRws(rOuter - 1) = strRws(rInner - 1): strRws(rInner - 1) = TempRs Else End If Next rInner Next rOuter strSuc = Join(strRws(), " ") Dim Segs As Long: Segs = Int(((Len(strSuc) - Len(Replace(strSuc, " ", ""))) + 1) / 27) + 1 For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34 strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) Next Cnt strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(Split(strSuc)) + 1) & ")"): strRws() = Split(strSuc) Dim arrOut() As Variant arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms()) With ThisWorkbook.Worksheets("consultant doctor") For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total" Dim Cl As Long For Cl = 4 To 24 arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" Next Cl arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature" .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 .HPageBreaks.Add .Range("A" & Cnt + 7 & "") Next Cnt .Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() With .UsedRange .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit End With .Rows("7:7").RowHeight = 50 .Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete End With strRws() = Split(strSpit) strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6) For rOuter = 2 To UBound(strNms) For rInner = rOuter + 1 To UBound(strNms) If strNms(rOuter) > strNms(rInner) Then varTemp = strNms(rOuter): strNms(rOuter) = strNms(rInner): strNms(rInner) = varTemp TempRs = strRws(rOuter - 1): strRws(rOuter - 1) = strRws(rInner - 1): strRws(rInner - 1) = TempRs Else End If Next rInner Next rOuter strSpit = Join(strRws(), " ") Segs = Int(((Len(strSpit) - Len(Replace(strSpit, " ", ""))) + 1) / 27) + 1 For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34 strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) Next Cnt strRws() = Split(strSpit) strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) & ")") strRws() = Split(strSpit) arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms()) With ThisWorkbook.Worksheets("Specialist Doctor") For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total" For Cl = 4 To 24 arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))" Next Cl arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature" .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 .HPageBreaks.Add .Range("A" & Cnt + 7 & "") Next Cnt .Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut() With .UsedRange .Font.Name = "Times New Roman" .Font.Size = 13 .Columns("D:X").NumberFormat = "0.00" .EntireColumn.AutoFit End With .Rows("7:7").RowHeight = 50 .Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete End With Application.ScreenUpdating = True End Sub

In support of these Threads
' https://www.ozgrid.com/forum/index.p...ng-a-2d-array/
' https://www.excelforum.com/excel-pro...dim-array.html
https://www.excelforum.com/tips-and-...ml#post5408376

I am not totally sure what the OP is asking.
Is the OP asking
(i) _ to put values into an existing array where that existing array already has values in it
or
(ii)_ changing the array dimension and positioning of elements in an array
or
(iii)_ maybe its lost in the translation and/ or the OP is not sure him/herself.
The initial answer to (i)_ I think we seem clear about:- It will likely in VBA require a code line for each element to be “moved” from one array to the other , so likely looping will be involved for a multi element array.
The Thread title and OPs first question infers to me converting a 1 D array to a 2 D array, without looping.
If the existing array with values already in it is a dynamic array, then overwriting along with re dimensioning means that those (i)_ and (ii)_ are somewhat merged in meaning anyway.
So I am not totally clear what is going on here, but I think it there is a discussion of generally … …”1 D arrays to 2 D arrays”
So lets say we are talking generally about …”1 D arrays to 2 D arrays” and leave it loosely defined for now and go with that…

Frederick has shown in his second code line that a characteristic of the Transpose function is that if a 1 D array is given to the Transpose function then the transposed array becomes a 2 D array , all be it a quasi “1 column array” ***
Transpose does that, as it does the opposite way converting a single column 2D array to a 1D array.
I think most of us are not quite sure why it has been wired to do that. Some other things seem to default to making a “one row” thing be a 1D array rather than a 2D array, even when the thing it may have been given to work on was a 2D array. ( It does not screw things up to badly when playing with spreadsheets since that transposed in its final 1 D form will be “seen” by Excel as if it was a single row 2 Dimensional array when applied to a spreadsheet range. So usually a “row” becomes a row, if you catch my drift).
We can go the other way. ( If we do that with Rick’s example , we will see a small difference, the 1 D array returned will have indices of 1 2 3 4 5 as opposed to the 0 1 2 3 4 , (since the Split function Rick used returns those starting a base 0 ) . I am not sure why Excel chooses to start a t 1 in this case: Possibly it was just made that way because its more often to do with worksheet/spreadsheet stuff, and we think about rows and columns starting at 1, and something like a row of 1 is a bit stupid. )

Index with arrays as co ordinate arguments
This stuff is worth knowing about:
A further function that can be very helpful in doing this sort of manipulation of arrays without looping is the Index Function. It becomes so useful because it will accept arrays in place of the more conventional single value indices in its second ( row ) and third ( column ) arguments. The evaluation is then done in the conventional Excel way, “along the columns of a row” , then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row , ….etc. Usually VBA will do its best to give out the results in an array dimensioned appropriate for the array dimensions supplied in those second and third arguments, following the conventional “along the columns of a row” , then down to repeat at the next row: along the columns of that row, ………

As example we can do that Transpose code line in this pseudo way

Code:

' Index(OneDimensionalArray(), 1 , 1 ' 1 2 ' 1 3 ' 1 4 ' 1 5 )

We are doing 5 calculations there, talking each time the first row and consecutive columns, the result coming out in a form that the Excel calculations are done - .. “along the columns of a row” , then down to repeat at the next row… but we only have one column in this case, so that is actually just going down the rows, 5 times. Hence our output is the 90degree transpose of OneDimensionalArray()

That was just one example, but the important point is that you can supply different arrays in the Index second ( “row” ) and third ( “column” ) arguments. So you can pretty well take any1 or 2 D array in the Index first argument, and in one code line, without looping , put all or some of the values from that array in some other order in any other 1 or 2 D array. That could be what the OP was asking for ….
Dim Array1(2, 2) As Integer
Dim Array2(2) As Integer
…………… way to copy the values from Array2 into Array1?
The restriction is that we can’t make use of this to put values into Array1( ) if it already existed. You would have to be in like having
Dim Array1() As Variant
Dim Array2(2) As Integer
-……..
Array1()= Index ( Array2(2) , { _.... } , { _... } )
( Variant is needed in the first declaration as the index chucks its output values housed in Variant types. AFAIK the first argument can be any sort of 1 D or 2 D array, ( or it can be any range object ) )

Another not looping option to assist in a conversion could be to remove rows or columns of a 2 D array with a single code line. Best look at some posts of Rick ( Frederick Rothstein ‘s ) , stuff for that ( https://excelfox.com/forum/showthrea...-Variant-Array )

One last curiosity , a weird thing I only recently came across. An array of arrays, sometimes refereed as a “jagged array”, is peculiarly treated in some cases by Index as a 2 D array. This gives us some interesting further one liner code line possibilities.
Example, If I had a 1 D array of 1 D arrays, something of this sort of form
{ { “Head1” , 2, 3 } , {“Head3”, 4, 5 } , {“Haed2”, 7, 9} }
then I can convert that, for example, to re ordered in data columns like this

Code:

' Head1 , Haed2 , Head3 ' 2 , 7 , 4 ' 3 , 9 , 5

I can do that using like a Index one code liner pseudo

Code:

' Index( Head1 , 2, 3 1 , 3 , 2 1 , 1 , 1 ' Head3 , 4, 5 1 , 3 , 2 2 , 2 , 2 ' Haed2 , 7, 9 1 , 3 , 2 3 , 3 , 3 )

I put some more details of all I have been saying , in a macro in the uploaded file. Probably its best to step through the macro in Debug mode ( do that by hitting Key F8 after clicking anywhere in the macro )

Quote:

Originally Posted by vba_php

....to be honest with you I've never seen your type of question asked in 20 years of writing code my lifetime. ....

Hello Adam.
I expect you are referring specifically to the idea of putting existing values from an array into another existing array, although I am not fully clear if the OP wanted that: Possibly the language barrier prevented the OP getting anything out of the links you gave him…. The best thing probably, as Rory asked for, was an example from the OP of what he wanted to do…
Anyway, you probably know all the following, but I thought I’d add it to the Thread, while I am in the mood…
Generally questions along the lines of “1 D array to 2 D array” or visa versa are quite common in Excel VBA. I expect this is because
_ a) a lot of things done “internally” in coding involve 1 D arrays,
but/ and
_ b) a range from a spreadsheet will often likely end up in an array of 2 Dimensions, I think Excel does this so that we can make the distinction what is a row and what is a column.***
So things might not always work as we wanted, for example a problem might occur when a 1 D array appears when a 2 D array was expected/ wanted, and visa versa. To solve the problem a conversion from a 1D to 2D or visa versa might get us out of trouble.
Example: we got a Join function that is something like the reverse of the Split function mentioned in this Thread . Basically you can use it to join the contents of an array into a string. The bummer is that it only accepts a 1 D array. So if I give it a column or row of data to join it will error. You’ll need to change the 2D array got from a spreadsheet single row or a spreadsheet single column to a 1D array for join to work on it. ( One way you can do that is with some of the one liner codings I been talking about – I added a example for you in the uploaded macro ### )

***I suppose a 2 D array does not really have “rows” and “columns”, it simply has 2 dimensions. But Excel conventionally puts a spreadsheet row into the fist dimension, and a spreadsheet column into the second dimension. So after using Excel VBA arrays a lot you often get to think of a 2 D array in terms of like arr(row, column) or in terms of orientation like arr(horizontal, vertical). Its just a convenient frame of reference perception.
A 1 D array has no orientation. I can’t really perceive that unless I have drunk a lot of Jack Daniels, as the world starts spinning around, then it becomes very clear, relatively speaking. I suppose Excel can’t get drunk, and as mentioned, a 1 D array seems to be often regarded as like a 2 D array of first dimension size of 1, or pseudo 1 “row” 2 D array.

Molly

Adam, I have definitely had random occurrences of an error like you mentioned, all be it very rarely. When it has happened , I was pretty damm sure it shouldn’t have happened.
I think we all agree that Activateing and Selecting when dealing with worksheet ranges via VBA is rarely needed and is usually a bad idea as the interaction with a spreadsheet slams the brakes on.

I will usually optimise a macro first, with no Activateing and Selecting , ignoring the odd error of that sort you mentioned.
After that I will often see if I don’t compromise the performance much if I add an occasional code line pair of something like
Worksheet("x").Activate: Worksheet("x").Range("A1").Select
Or, if dealing with multiple open workbooks,
Workbooks("x“).Activate: Worksheet("x").Activate: Worksheet("x").Range("A1").Select
at some strategic points.

A typical point would be just before I start doing things to ranges in Worksheet("x") via VBA. I know those two ( three ) code lines should be unnecessary. But it’s been my experience that they help stop that occasional error.
I have no idea what causes the occasional error when all suggest it should not error. I think possibly Excel has some memories of what was last active. Possibly that can become corrupted, and doing a quick Worksheet("x").Activate: Worksheet("x").Range("A1").Select refreshes it.

One thing that has already been touched on here in the Thread a couple of times, which has caught me out a few times: Selecting a range does not activate the worksheet of the range you select.
If the worksheet is not active and you try to select that range then you will get that error.
But selecting a worksheet does activate that worksheet. (Activateing and Selecting a worksheet do something similar, - I think the main difference being that you can select things, but only activate a thing. I have not explored that much yet… )

Quote:

Originally Posted by vba_php

…but based on the millions of tests that I ran, it became evident that this line of code automatically made the book active:

Code:

wbDrawings.SaveAs (ThisWorkbook.Path & Application.PathSeparator & "temp.csv")

.....

I would hazard a guess that that might be version dependent and possibly unreliable, as Rory suggested. That dose not consistently activate the workbook being saved, for me.

Molly

Some additional notes and extended explanations in support of answer to this Thread
https://eileenslounge.com/viewtopic....fc302dc186f01b

The OP has this
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )

_Row\^Col A B C D E F G

1 Header1 Header2 Header3 Header4 Header5 Header6 Header7

2 101 H2_1 H3_1 H4_1 H5_1 H6_1 H7_1

3 102 H2_2 H3_2 H4_2 H5_2 H6_2 H7_2

4 103 H2_3 H3_3 H4_3 H5_3 H6_3 H7_3

5 102 H2_4 H3_4 H4_4 H5_4 H6_4 H7_4

6 101 H2_5 H3_5 H4_5 H5_5 H6_5 H7_5

7 103 H2_6 H3_6 H4_6 H5_6 H6_6 H7_6

8 105 H2_7 H3_7 H4_7 H5_7 H6_7 H7_7

9 104 H2_8 H3_8 H4_8 H5_8 H6_8 H7_8

Worksheet: Source

This what the OP wants
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )

_Row\^Col C D E F

2 MyTarget Header3 Header4 Header7

3 101 H3_1 H4_1 H7_1

4 101 H3_5 H4_5 H7_5

5 101

6 102 H3_2 H4_2 H7_2

7 103 H3_3 H4_3 H7_3

8 103 H3_6 H4_6 H7_6

9 104 H3_8 H4_8 H7_8

10 108

11 105 H3_7 H4_7 H7_7

Worksheet: Target

Here again what the OP wants, with explanations:

Expected Result

MyTarget Header3 Header4 Header7

101 H3_1 H4_1 H7_1 first instance

101 H3_5 H4_5 H7_5 second instance

101 third instance (there is no third instance so left empty)

102 H3_2 H4_2 H7_2

103 H3_3 H4_3 H7_3

103 H3_6 H4_6 H7_6

104 H3_8 H4_8 H7_8

108 left empty as there is no 108 in Source

105 H3_7 H4_7 H7_7

You can see that it comes from the source worksheet:

Header1 Header2 Header3 Header4 Header5 Header6 Header7

101 H2_1 H3_1 H4_1 H5_1 H6_1 H7_1

102 H2_2 H3_2 H4_2 H5_2 H6_2 H7_2

103 H2_3 H3_3 H4_3 H5_3 H6_3 H7_3

102 H2_4 H3_4 H4_4 H5_4 H6_4 H7_4

101 H2_5 H3_5 H4_5 H5_5 H6_5 H7_5

103 H2_6 H3_6 H4_6 H5_6 H6_6 H7_6

105 H2_7 H3_7 H4_7 H5_7 H6_7 H7_7

104 H2_8 H3_8 H4_8 H5_8 H6_8 H7_8

Rem 1
The main start point on my logic is obtaining ( in a dynamic way ) a range ( in an array , arrSrch() , ) that looks like this

Header1 Header3 Header4 Header7

101 H3_1 H4_1 H7_1

102 H3_2 H4_2 H7_2

103 H3_3 H4_3 H7_3

102 H3_4 H4_4 H7_4

101 H3_5 H4_5 H7_5

103 H3_6 H4_6 H7_6

105 H3_7 H4_7 H7_7

104 H3_8 H4_8 H7_8

Note: The array arrSrch() has an extra empty row
https://imgur.com/fKjli8W https://i.imgur.com/fKjli8W.jpg

What we do with that is the subject of Rem 2 , and is explained in the next post

_Row\^Col	A	B	C	D	E	F	G
1	Header1	Header2	Header3	Header4	Header5	Header6	Header7
2	101	H2_1	H3_1	H4_1	H5_1	H6_1	H7_1
3	102	H2_2	H3_2	H4_2	H5_2	H6_2	H7_2
4	103	H2_3	H3_3	H4_3	H5_3	H6_3	H7_3
5	102	H2_4	H3_4	H4_4	H5_4	H6_4	H7_4
6	101	H2_5	H3_5	H4_5	H5_5	H6_5	H7_5
7	103	H2_6	H3_6	H4_6	H5_6	H6_6	H7_6
8	105	H2_7	H3_7	H4_7	H5_7	H6_7	H7_7
9	104	H2_8	H3_8	H4_8	H5_8	H6_8	H7_8

_Row\^Col	C	D	E	F
2	MyTarget	Header3	Header4	Header7
3	101	H3_1	H4_1	H7_1
4	101	H3_5	H4_5	H7_5
5	101
6	102	H3_2	H4_2	H7_2
7	103	H3_3	H4_3	H7_3
8	103	H3_6	H4_6	H7_6
9	104	H3_8	H4_8	H7_8
10	108
11	105	H3_7	H4_7	H7_7

Continued from last post

Rem 2
We build up a Main 1D array whose elements are themselves 1 D arrays of the required output rows.
This is done by looping down the target range rows , arTgt() = WsT.Range("C2:C" & LrT & "").Value
At each loop we look for a match of the target range row value in the first column of arrSrch()
We then do the array Split type technique ( https://excelfox.com/forum/showthrea...lication-Index ) to get a 1 D array of the required row. That row is added to the Main 1 D array
We then remove that row from arrSrch() ( using a function from Rick Rothstein https://excelfox.com/forum/showthrea...-Variant-Array ).
Then we move on to the next target range row down

Rem 3
Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic....266691#p266691
For demo purposes, the macro in the next post pastes out the result in a spare worksheet range:

Code:

' Example paste out CHANGE Top left cell H35 to suit Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut() ' ** -1 is a bodge to knock off the extra row End Sub

_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )

_Row\^Col H I J

35 H3_1 H4_1 H7_1

36 H3_5 H4_5 H7_5

37

38 H3_2 H4_2 H7_2

39 H3_3 H4_3 H7_3

40 H3_6 H4_6 H7_6

41 H3_8 H4_8 H7_8

42

43 H3_7 H4_7 H7_7

Worksheet: Target

Macro, Sub BrdShlss() , and a couple of required Functions are here:
https://excelfox.com/forum/showthrea...ll=1#post14907

_Row\^Col	H	I	J
35	H3_1	H4_1	H7_1
36	H3_5	H4_5	H7_5
37
38	H3_2	H4_2	H7_2
39	H3_3	H4_3	H7_3
40	H3_6	H4_6	H7_6
41	H3_8	H4_8	H7_8
42
43	H3_7	H4_7	H7_7

Macro for these posts
https://excelfox.com/forum/showthrea...ll=1#post14905
https://excelfox.com/forum/showthrea...ll=1#post14906
http://www.eileenslounge.com/viewtopic.php?f=30&t=35303

Code:

Option Explicit Sub BrdShlss() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35303 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907 Rem 1 worksheets data info Dim WsS As Worksheet, WsT As Worksheet Set WsS = ThisWorkbook.Worksheets("Source"): Set WsT = ThisWorkbook.Worksheets("Target") Dim LrS As Long, LrT As Long, LcS As Long, LcT As Long Let LrS = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row Let LrT = WsT.Range("C" & WsT.Rows.Count & "").End(xlUp).Row Let LcS = WsS.Cells(1, WsS.Columns.Count).End(xlToLeft).Column Let LcT = WsT.Cells(2, WsT.Columns.Count).End(xlToLeft).Column Dim arSrc() As Variant ', arSrcA() As Variant Let arSrc() = WsS.Range("A1:" & CLtr(LcS) & LrS + 1 & "").Value ' + 1 is to give us an extra empty row ' Let arSrcA() = WsS.Range("A1:A" & LrS & "").Value Dim arTgt() As Variant: Let arTgt() = WsT.Range("C2:C" & LrT & "").Value '1b) determine what columns are needed for our search range, since typically not all are needed Dim strClms As String: Let strClms = "1" Dim SrchHd() As Variant: Let SrchHd() = WsT.Range("D2:" & CLtr(LcT) & "2").Value Dim SrcHd() As Variant: Let SrcHd() = WsS.Range("A1:" & CLtr(LcS) & "1").Value Dim Cnt As Long For Cnt = 1 To UBound(SrchHd(), 2) Dim MtchRes As Long ' Note I assume there is always a match in Headers between sheet ranges, so that I always have a number and not an error string Let MtchRes = Application.Match(SrchHd(1, Cnt), SrcHd(), 0) Let strClms = strClms & " " & MtchRes ' add a required column indicie Next Cnt ' Let strClms = Left(strClms, (Len(strClms) - 1)) ' remove last unwanted space For the given example this gives us "3 4 7" Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & LrS + 1 & ")") ' + 1 is to give us an extra empty row Dim arrSrch() As Variant ' This will be the reduced size range we need to search in - it has just the headers required Let arrSrch() = Application.Index(arSrc(), RwsT(), Split(strClms, " ", -1, vbBinaryCompare)) ' In our example Split(strClms, " ", -1, vbBinaryCompare)) is {1, 3, 4, 7) ' Let Range("H24").Resize(UBound(arrSrch(), 1), UBound(arrSrch(), 2)).Value = arrSrch() '1c) Get initial row string indicies for current source range 'Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & UBound(arSrc(), 1) & ")") ' Typical "vertical" array of row indices needed in Index(Arr, Rws(), Clms()) type code line 'Dim Rws() As Variant: Let Rws() = Application.Index(RwsT(), Evaluate("=Column(A:" & CLtr(UBound(RwsT, 1)) & ")"), Evaluate("=Column(A:" & CLtr(UBound(RwsT(), 1)) & ")/Column(A:" & CLtr(UBound(RwsT(), 1)) & ")")) ' Transpose the "vertical array to get a 1 Dimenrional "horizontal" array 'Dim strRws As String: Let strRws = " " & Join(Rws(), " ") & " " ' This is a string of our row indicies, and later we will remove some indicies as we go along then work the steps above backwards to get a modified RwsT() to use in Index(Arr, Rws(), Clms()) type code line for a new reduced content search array Rem 2 Building output array Dim arrOut() As Variant ' A 1 D array for the 1 D arrays at each match ' 2b) main loop for all rows of MyTarget For Cnt = 2 To UBound(arTgt(), 1) Step 1 ReDim Preserve arrOut(1 To Cnt - 1) Dim arSrcA() As Variant: Let arSrcA() = Application.Index(arrSrch(), 0, 1) ' the first column of our current arrSrch() ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Dim VarMtchres As Variant Let VarMtchres = Application.Match(arTgt(Cnt, 1), arSrcA(), 0) If IsError(VarMtchres) Then ' we need to add an empty row which we have as the last row of arrSrch() Let arrOut(Cnt - 1) = Application.Index(arrSrch(), UBound(arrSrch(), 1), 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index Else Let arrOut(Cnt - 1) = Application.Index(arrSrch(), VarMtchres, 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index '2b(ii) we must remove the row from the arrSrch() Let arrSrch() = DeleteArrayRow(arrSrch(), (VarMtchres)) End If Next Cnt Rem 3 ' Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic.php?p=266691#p266691 Let arrOut() = Application.Index(arrOut(), RwsT(), Evaluate("=Column(B:" & CLtr(UBound(arrSrch(), 2)) & ")")) ' ** this is actually 1 row too big ' Example paste out CHANGE Top left cell H35 to suit Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut() ' ** -1 is a bodge to knock off the extra row End Sub ' https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array Function DeleteArrayRow(Arr As Variant, RowToDelete As Long) As Variant Dim Rws As Long, Cols As String Rws = UBound(Arr) - LBound(Arr) Cols = "A:" & Split(Columns(UBound(Arr, 2) - LBound(Arr, 2) + 1).Address(, 0), ":")(0) DeleteArrayRow = Application.Index(Arr, Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(Arr) & ")"))))), Evaluate("COLUMN(" & Cols & ")")) End Function ' https://excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number Public Function CLtr(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980 Do: Let CLtr = Chr(65 + (((lclm - 1) Mod 26))) & CLtr: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0 End Function

Some notes in support of these Threads
https://excelfox.com/forum/showthrea...urning-Nothing
https://excelfox.com/forum/showthrea...sult-Using-VBA

Google Browser Page HTML Source
Typically,
_ the first main section in internet page manipulation codings which try to get things from internet sites, is a code section which gets you a single, very long, text string of something similar to what your browser actually uses to present all you see.
( Google Browser also allows you to see in the browser all that text if you right click and select something like Show Page Source ( or use short cut key combination of Strg+u )
ShowPageSource.JPG PageSource.JPG :
https://imgur.com/UnAs5Le , https://imgur.com/bubFTet
https://i.imgur.com/UnAs5Le.jpg , https://i.imgur.com/bubFTet.jpg )

I am not 100% familiar with all the syntaxes and workings of this first code section, but usually they are similar in such codings, and usually I can get that code section to get the HTML page Source text string, ( and we can add a few extra code lines if we want to put all that text string into a text file , so that we can look at it , and use the simple search facility within a text editor, such as Notepad , to find things in that very long text string )
This first code section will get me that text string for a Google Search of ExcelFox , and it will put it in a text file with the name
GoogleSrchExcelFox.txt

Code:

Sub GoogleSearchURL() ' https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA On Error GoTo Bed '_1 First section get the long text string of the HTML coding of the internet Page '_1(i) get the long single text string With CreateObject("msxml2.xmlhttp") .Open "GET", "https://www.google.com/search?q=ExcelFox", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response. 'No extra info here for type GET .setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo" '.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers. .send ' varBody:= ' No extra info for type GET. .send actually makes the request While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string End With '_1(ii) Optional secion to put the text string into a text file , for ease of code developments Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function Dim PathAndFileName2 As String Let PathAndFileName2 = ThisWorkbook.Path & "\" & "GoogleSrchExcelFox" & ".txt" ' CHANGE TO SUIT Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there Print #FileNum2, PageSrc ' Close #FileNum2

_ The second part of such internet page manipulation coding involve often putting that text into an Object that allows a Object oriented programming type analysis of the web page. That is rather advanced and I personally am not too experienced with that.

What I am proposing is a much simplified approach I used myself successfully a few times. It is so simple, that I guess it may not be reliable permanently, for example, when a small change is made to the source page coding by Google. On the other hand , often major changes make the more advanced coding no longer work.
My solution is probably best only to use if you can understand enough to modify it yourself later when it no longer works. That is why I will explain it in detail here.

Examine the string to find the info you want
My solution does very simple basic string manipulation to pick out what I want.
As example, I do google search for ExcelFox manually and programmatically…_
_ Manually:
https://imgur.com/M16cko3 : https://i.imgur.com/M16cko3.jpg
_ Programmatically :
I run the macro snippet above, and look at the text file produced in a text editor. Then I use the search option to look for ExcelFox
NotepadSearch.JPG , Notepad Search.JPG
https://imgur.com/L9dcXBf , https://imgur.com/K4kl3qk
https://i.imgur.com/L9dcXBf.jpg , https://i.imgur.com/K4kl3qk.jpg
If I compare the results of manually and programmatically, then I can pick out a pattern. ( Note: you must look at all the occurrences of ExcelFox – Some will be as part of a text that you don’t want, but you will see a match between the things shown manually, and the text got programmatically.
Example
My manual search got me this: ExcelFoxManaulGooglesearch.JPG : https://imgur.com/M16cko3
https://i.imgur.com/M16cko3.jpg
Consider the first three main URLs given by the search :
http://www.excelfox.com/forum/forum.php
https://excelfox.com/forum/forumdisp...p/2-Excel-Help
http://www.hifi-forum.de/bild/excel-...0e_737672.html
If I search in the text file, I can pick out those inside a similar text section…

Code:

' q=ExcelFox&source=lnms&tbm=nws&sa=X&ved=0ahUKEwjO9PiFs6jsAhXJzoUKHUj-DwcQ_AUIBygD">NEWS</a></td></tr></tbody></table></div></div><div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=http://www.excelfox.com/forum/forum.php&sa=U&ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj-DwcQFjAAegQIBxAB&usg=AOvVaw3c8Z4i7W8Ooq7f9a8C3CKw"><span class="CVA68e qXLe6d">Excel, ' <span class="qXLe6d FrIlee"> <span class="fYyStc">Have a question in Excel, Access, Powerpoint, Word or Outlook? Ask http://www.?excelfox.com/forum/forum.php.</span> </span> </div> </div></td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://excelfox.com/forum/forumdisplay.php/2-Excel-Help&sa=U&ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj- ' Weitere Ergebnisse von excelfox.com</a> </span> </div> </div></td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=http://www.hifi-forum.de/bild/excel-fox-700e_737672.html&sa=U&ved=2ahUKEwjO9PiFs6jsAhXJzoUKHUj-DwcQFjACegQIABAB&usg=AOvVaw1WljIWpaSLwuTcgdbTcLeU"><span class="CV

I now repeat the above experiment for a Google search on Chandoo
Manual search results:
ChandooManaulGooglesearch.JPG : https://imgur.com/eQSDHsz
https://i.imgur.com/eQSDHsz.jpg
Considering again just the first 3 results , we have
https://chandoo.org/
https://www.youtube.com/channel/UC8u...MHeeRma49dtZKA
https://de.wikipedia.org/wiki/Chandu
Programmatic ( looking through the produced text file to find something similar to the first 3 URLs from the manual search)
( This would be the macro to get the text file from that search : https://excelfox.com/forum/showthrea...ll=1#post14992 )

Code:

' /table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://chandoo.org/&sa=U&ved=2ahUKEwiFs9-r4KrsAhWNC-wKHSLMBb0QFjACegQICBAB& ' <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://www.youtube.com/channel/UC8uU_wruBMHeeRma49dtZKA&sa=U&ved=2ahUKEwiFs9-r4KrsA ' /td></tr></table></div></div></div> </div> </div><div> <div> <div class="ezO2md"><div><div><a class="fuLhoc ZWRArf" href="/url?q=https://de.wikipedia.org/wiki/Chandu&sa=U&ved=2ahUKEwiFs9-r4KrsAhWNC-wKHSLMBb0QFjAEegQIARAB&usg=AOvVaw323MmSfVaurlycQW8E02XJ"><span class="CVA68e qXLe6d">Chandu – Wikipedia</span> <span class="qXLe6d dX

Solution based on simple string analysis
It appears as if we can easily pick out our required URLs from the text if we look for some of the text appearing just before all the URLs.
We could try for example, class="fuLhoc ZWRArf" href="/url?q=
We know then that the text after is out wanted URL
We can also see that we have consistently the same string after URL, so we know we can look for that in order to know the end of the URL text
The implementation of this is fairly simple VBA string manipulation.

Macro to get the text file from Google search on Chandoo

Some notes in support of these Threads
https://excelfox.com/forum/showthrea...urning-Nothing
https://excelfox.com/forum/showthrea...sult-Using-VBA

Code:

Sub GoogleSearchURL() ' https://excelfox.com/forum/showthread.php/2656-Automated-Search-Results-Returning-Nothing https://excelfox.com/forum/showthread.php/973-Lookup-First-URL-From-Google-Search-Result-Using-VBA On Error GoTo Bed '_1 First section get the long text string of the HTML coding of the internet Page '_1(i) get the long single text string With CreateObject("msxml2.xmlhttp") .Open "GET", "https://www.google.com/search?q=Chandoo", False ' 'just preparing the request type, how and what type... "The True/False argument of the HTTP Request is the Asynchronous mode flag. If set False then control is immediately returns to VBA after Send is executed. If set True then control is returned to VBA after the server has sent back a response. 'No extra info here for type GET .setRequestHeader bstrheader:="Ploppy", bstrvalue:="Poo" '.setRequestHeader bstrheader:="If-Modified-Since", bstrvalue:="Sat, 1 Jan 2000 00:00:00 GMT" ' https://www.autohotkey.com/boards/viewtopic.php?t=9554 --- It will caching the contents of the URL page. Which means if you request the same URL more than once, you always get the same responseText even the website changes text every time. This line is a workaround : Set cache related headers. .send ' varBody:= ' No extra info for type GET. .send actually makes the request While .readyState <> 4: DoEvents: Wend ' Allow other processes to run while the web page loads. Think this is part of the True option Dim PageSrc As String: Let PageSrc = .responseText ' Save the HTML code in the (Global) variable. ': Range("P1").Value = PageSrc 'For me for a print out copy to text file etc. The responseText property returns the information requested by the Open method as a text string End With '_1(ii) Optional secion to put the text string into a text file , for ease of code developments Dim FileNum2 As Long: Let FileNum2 = FreeFile(0) ' https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/freefile-function Dim PathAndFileName2 As String Let PathAndFileName2 = ThisWorkbook.Path & "\" & "Chandoo" & ".txt" ' CHANGE TO SUIT Open PathAndFileName2 For Output As #FileNum2 ' CHANGE TO SUIT ' Will be made if not there Print #FileNum2, PageSrc ' Close #FileNum2 End Sub

In support of this Thread
https://excelfox.com/forum/showthrea...tiple-Criteria
and answer
https://excelfox.com/forum/showthrea...ll=1#post15046

This is what the transpose of SM_T_D1() looks like ( SM_T_D1() is actually pseudo horizontal rather than vertical , as it is a 1D array )
_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

Sales Man Territory Dimension

John New York Tissue

Alfred Washington Soda

John New York Soda

Alfred New York Tissue

Leo Washington Soda

Leo New York Tissue

Maxwell Washington Towel

Here is the equivalent transpose of array, SM_T_D2()
_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

Sales Man Territory Dimension

John New York Tissue

John New York Soda

John New York Paper

John New York Towel

John Washington Tissue

John Washington Soda

John Washington Paper

John Washington Towel

Alfred New York Tissue

Alfred New York Soda

Alfred New York Paper

Alfred New York Towel

Alfred Washington Tissue

Alfred Washington Soda

Alfred Washington Paper

Alfred Washington Towel

Leo New York Tissue

Leo New York Soda

Leo New York Paper

Leo New York Towel

Leo Washington Tissue

Leo Washington Soda

Leo Washington Paper

Leo Washington Towel

Maxwell New York Tissue

Maxwell New York Soda

Maxwell New York Paper

Maxwell New York Towel

Maxwell Washington Tissue

Maxwell Washington Soda

Maxwell Washington Paper

Maxwell Washington Towel

In support of this answer
https://excelfox.com/forum/showthrea...ll=1#post15046

Before:
___ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col A B C D E

1 Sales Man Territory Dimension Sales Amt Cost

2 John New York Tissue
1,000.00

200.00

3 Alfred Washington Soda
2,100.00

700.00

4 John New York Soda
2,050.00

1,500.00

5 Alfred New York Tissue
2,000.00

500.00

6 Leo Washington Soda
200.00

100.00

7 Leo New York Tissue
3,500.00

1,500.00

8 Maxwell Washington Towel
1,000.00

800.00

Worksheet: Export1

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col A B C D E

1 Sales Man Territory Dimension Sales Amt Cost

2 John New York Tissue

3 John New York Soda

4 John New York Paper

5 John New York Towel

6 John Washington Tissue

7 John Washington Soda

8 John Washington Paper

9 John Washington Towel

10 Alfred New York Tissue

11 Alfred New York Soda

12 Alfred New York Paper

13 Alfred New York Towel

14 Alfred Washington Tissue

15 Alfred Washington Soda

16 Alfred Washington Paper

17 Alfred Washington Towel

18 Leo New York Tissue

19 Leo New York Soda

20 Leo New York Paper

21 Leo New York Towel

22 Leo Washington Tissue

23 Leo Washington Soda

24 Leo Washington Paper

25 Leo Washington Towel

26 Maxwell New York Tissue

27 Maxwell New York Soda

28 Maxwell New York Paper

29 Maxwell New York Towel

30 Maxwell Washington Tissue

31 Maxwell Washington Soda

32 Maxwell Washington Paper

33 Maxwell Washington Towel

Worksheet: ResultVBA

_Row\^Col	A	B	C	D	E
1	Sales Man	Territory	Dimension	Sales Amt	Cost
2	John	New York	Tissue	1,000.00	200.00
3	Alfred	Washington	Soda	2,100.00	700.00
4	John	New York	Soda	2,050.00	1,500.00
5	Alfred	New York	Tissue	2,000.00	500.00
6	Leo	Washington	Soda	200.00	100.00
7	Leo	New York	Tissue	3,500.00	1,500.00
8	Maxwell	Washington	Towel	1,000.00	800.00

_Row\^Col	A	B	C	D	E
1	Sales Man	Territory	Dimension	Sales Amt	Cost
2	John	New York	Tissue
3	John	New York	Soda
4	John	New York	Paper
5	John	New York	Towel
6	John	Washington	Tissue
7	John	Washington	Soda
8	John	Washington	Paper
9	John	Washington	Towel
10	Alfred	New York	Tissue
11	Alfred	New York	Soda
12	Alfred	New York	Paper
13	Alfred	New York	Towel
14	Alfred	Washington	Tissue
15	Alfred	Washington	Soda
16	Alfred	Washington	Paper
17	Alfred	Washington	Towel
18	Leo	New York	Tissue
19	Leo	New York	Soda
20	Leo	New York	Paper
21	Leo	New York	Towel
22	Leo	Washington	Tissue
23	Leo	Washington	Soda
24	Leo	Washington	Paper
25	Leo	Washington	Towel
26	Maxwell	New York	Tissue
27	Maxwell	New York	Soda
28	Maxwell	New York	Paper
29	Maxwell	New York	Towel
30	Maxwell	Washington	Tissue
31	Maxwell	Washington	Soda
32	Maxwell	Washington	Paper
33	Maxwell	Washington	Towel

In support of this Thread
https://excelfox.com/forum/showthrea...tiple-Criteria
and answer
https://excelfox.com/forum/showthrea...ll=1#post15046

After running Sub Arrays1()

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col A B C D E

1 Sales Man Territory Dimension Sales Amt Cost

2 John New York Tissue 1000 200

3 John New York Soda 2050 1500

4 John New York Paper

5 John New York Towel

6 John Washington Tissue

7 John Washington Soda

8 John Washington Paper

9 John Washington Towel

10 Alfred New York Tissue 2000 500

11 Alfred New York Soda

12 Alfred New York Paper

13 Alfred New York Towel

14 Alfred Washington Tissue

15 Alfred Washington Soda 2100 700

16 Alfred Washington Paper

17 Alfred Washington Towel

18 Leo New York Tissue 3500 1500

19 Leo New York Soda

20 Leo New York Paper

21 Leo New York Towel

22 Leo Washington Tissue

23 Leo Washington Soda 200 100

24 Leo Washington Paper

25 Leo Washington Towel

26 Maxwell New York Tissue

27 Maxwell New York Soda

28 Maxwell New York Paper

29 Maxwell New York Towel

30 Maxwell Washington Tissue

31 Maxwell Washington Soda

32 Maxwell Washington Paper

33 Maxwell Washington Towel 1000 800

Worksheet: ResultVBA

_Row\^Col	A	B	C	D	E
1	Sales Man	Territory	Dimension	Sales Amt	Cost
2	John	New York	Tissue	1000	200
3	John	New York	Soda	2050	1500
4	John	New York	Paper
5	John	New York	Towel
6	John	Washington	Tissue
7	John	Washington	Soda
8	John	Washington	Paper
9	John	Washington	Towel
10	Alfred	New York	Tissue	2000	500
11	Alfred	New York	Soda
12	Alfred	New York	Paper
13	Alfred	New York	Towel
14	Alfred	Washington	Tissue
15	Alfred	Washington	Soda	2100	700
16	Alfred	Washington	Paper
17	Alfred	Washington	Towel
18	Leo	New York	Tissue	3500	1500
19	Leo	New York	Soda
20	Leo	New York	Paper
21	Leo	New York	Towel
22	Leo	Washington	Tissue
23	Leo	Washington	Soda	200	100
24	Leo	Washington	Paper
25	Leo	Washington	Towel
26	Maxwell	New York	Tissue
27	Maxwell	New York	Soda
28	Maxwell	New York	Paper
29	Maxwell	New York	Towel
30	Maxwell	Washington	Tissue
31	Maxwell	Washington	Soda
32	Maxwell	Washington	Paper
33	Maxwell	Washington	Towel	1000	800

Some extra clarifying info for this thread
https://excelfox.com/forum/showthrea...tiple-Criteria
and specifically this post
https://excelfox.com/forum/showthrea...5048#post15048

For this range with Helper column

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col A B C D E F

1 Sales Man Territory Dimension Helper Column Sales Amt Cost

2 John New York Tissue John|New York|Tissue 1,000.00 200.00

3 Alfred Washington Soda Alfred|Washington|Soda 2,100.00 700.00

4 John New York Soda John|New York|Soda 2,050.00 1,500.00

5 Alfred New York Tissue Alfred|New York|Tissue 2,000.00 500.00

6 Leo Washington Soda Leo|Washington|Soda 200.00 100.00

7 Leo New York Tissue Leo|New York|Tissue 3,500.00 1,500.00

8 Maxwell Washington Towel Maxwell|Washington|Towel 1,000.00 800.00

Worksheet: Export

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

1

Helper Column

2

=A2&"|"&B2&"|"&C2

3

=A3&"|"&B3&"|"&C3

4

=A4&"|"&B4&"|"&C4

5

=A5&"|"&B5&"|"&C5

6

=A6&"|"&B6&"|"&C6

7

=A7&"|"&B7&"|"&C7

8

=A8&"|"&B8&"|"&C8

Worksheet: Export

Formula VLookUp

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IF(ISERROR(VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,2,FALSE)),"",VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,2,FALSE))

=IF(ISERROR(VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,3,FALSE)),"",VLOOKUP(A2&"|"&B2&"|"&C2,Export!$D$2:$F$8,3,FALSE))

Worksheet: ResultVLookUp

Formula Index

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IF(ISERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1)),"",INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1))

=IF(ISERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1)),"",INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)*(ResultIndex!B2=Export!$B$2:$B$8)*(ResultIndex!C2=Export!$C$2:$C$8),0),1))

Worksheet: ResultIndex

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IFERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex2!A2=Export!$A$2:$A$8)*(ResultIndex2!B2=Export!$B$2:$B$8)*(ResultIndex2!C2=Export!$C$2:$C$8),0),1),"")

=IFERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex2!A2=Export!$A$2:$A$8)*(ResultIndex2!B2=Export!$B$2:$B$8)*(ResultIndex2!C2=Export!$C$2:$C$8),0),1),"")

Worksheet: ResultIndex2

_Row\^Col	A	B	C	D	E	F
1	Sales Man	Territory	Dimension	Helper Column	Sales Amt	Cost
2	John	New York	Tissue	John\|New York\|Tissue	1,000.00	200.00
3	Alfred	Washington	Soda	Alfred\|Washington\|Soda	2,100.00	700.00
4	John	New York	Soda	John\|New York\|Soda	2,050.00	1,500.00
5	Alfred	New York	Tissue	Alfred\|New York\|Tissue	2,000.00	500.00
6	Leo	Washington	Soda	Leo\|Washington\|Soda	200.00	100.00
7	Leo	New York	Tissue	Leo\|New York\|Tissue	3,500.00	1,500.00
8	Maxwell	Washington	Towel	Maxwell\|Washington\|Towel	1,000.00	800.00

_Row\^Col	D
1	Helper Column
2	=A2&"\|"&B2&"\|"&C2
3	=A3&"\|"&B3&"\|"&C3
4	=A4&"\|"&B4&"\|"&C4
5	=A5&"\|"&B5&"\|"&C5
6	=A6&"\|"&B6&"\|"&C6
7	=A7&"\|"&B7&"\|"&C7
8	=A8&"\|"&B8&"\|"&C8

_Row\^Col	D	E
2	=IF(ISERROR(VLOOKUP(A2&"\|"&B2&"\|"&C2,Export!$D$2:$F$8,2,FALSE)),"",VLOOKUP(A2&"\|"&B2&"\|"&C2,Export!$D$2:$F$8,2,FALSE))	=IF(ISERROR(VLOOKUP(A2&"\|"&B2&"\|"&C2,Export!$D$2:$F$8,3,FALSE)),"",VLOOKUP(A2&"\|"&B2&"\|"&C2,Export!$D$2:$F$8,3,FALSE))

_Row\^Col	D	E
2	=IF(ISERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)(ResultIndex!B2=Export!$B$2:$B$8)(ResultIndex!C2=Export!$C$2:$C$8),0),1)),"",INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)(ResultIndex!B2=Export!$B$2:$B$8)(ResultIndex!C2=Export!$C$2:$C$8),0),1))	=IF(ISERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)(ResultIndex!B2=Export!$B$2:$B$8)(ResultIndex!C2=Export!$C$2:$C$8),0),1)),"",INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex!A2=Export!$A$2:$A$8)(ResultIndex!B2=Export!$B$2:$B$8)(ResultIndex!C2=Export!$C$2:$C$8),0),1))

_Row\^Col	D	E
2	=IFERROR(INDEX(Export!$E$2:$E$8,MATCH(1,(ResultIndex2!A2=Export!$A$2:$A$8)(ResultIndex2!B2=Export!$B$2:$B$8)(ResultIndex2!C2=Export!$C$2:$C$8),0),1),"")	=IFERROR(INDEX(Export!$F$2:$F$8,MATCH(1,(ResultIndex2!A2=Export!$A$2:$A$8)(ResultIndex2!B2=Export!$B$2:$B$8)(ResultIndex2!C2=Export!$C$2:$C$8),0),1),"")

Some extra clarifying info for this thread
https://excelfox.com/forum/showthrea...tiple-Criteria
and specifically this post
https://excelfox.com/forum/showthrea...5048#post15048

For this range

_____ Workbook: AllFormulasAndVBAMultipleCriteria.xlsm ( Using Excel 2007 32 bit )

_Row\^Col A B C D E

1 Sales Man Territory Dimension Sales Amt Cost

2 John New York Tissue 1,000.00 200.00

3 Alfred Washington Soda 2,100.00 700.00

4 John New York Soda 2,050.00 1,500.00

5 Alfred New York Tissue 2,000.00 500.00

6 Leo Washington Soda 200.00 100.00

7 Leo New York Tissue 3,500.00 1,500.00

8 Maxwell Washington Towel 1,000.00 800.00

Worksheet: Export1

Index Formulas

From P45cal

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IF(ISERROR(INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0))),"",INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)))

=IF(ISERROR(INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0))),"",INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)))

Worksheet: P45cal

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IFERROR(INDEX(Export1!D$1:D$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)),"")

=IFERROR(INDEX(Export1!E$1:E$9,MATCH($A2 & "¬" & $B2 & "¬" & $C2,Export1!$A$1:$A$9 & "¬" & Export1!$B$1:$B$9 & "¬" & Export1!$C$1:$C$9,0)),"")

Worksheet: P45cal1

From Alan ( DocAElstein )

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IF(ISERROR(INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1)),"",INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1))

=IF(ISERROR(INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1)),"",INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex!A2=Export1!$A$2:$A$8)*(ResIndex!B2=Export1!$B$2:$B$8)*(ResIndex!C2=Export1!$C$2:$C$8),0),1))

Worksheet: ResIndex

_____ Workbook: AllFormulasAndVBAMultipleCriteria2.xlsm ( Using Excel 2007 32 bit )

_Row\^Col
D

E

2

=IFERROR(INDEX(Export1!$D$2:$D$8,MATCH(1,(ResIndex2!A2=Export1!$A$2:$A$8)*(ResIndex2!B2=Export1!$B$2:$B$8)*(ResIndex2!C2=Export1!$C$2:$C$8),0),1),"")

=IFERROR(INDEX(Export1!$E$2:$E$8,MATCH(1,(ResIndex2!A2=Export1!$A$2:$A$8)*(ResIndex2!B2=Export1!$B$2:$B$8)*(ResIndex2!C2=Export1!$C$2:$C$8),0),1),"")

Worksheet: ResIndex2

_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

_Row\^Col	A	B	D	E	F	J	K	L	M	N	O	P	Q	T	U
1	NSE	EQ	NA	NA	NA	BUY	MARKET	NA	CLI	MIS	DAY	WC5758	NA	3	NA
2	NSE	EQ	NA	NA	NA	SELL	SL-M		CLI	MIS	DAY	WC5758	NA	NA	NA
3	NSE	EQ	NA	NA	NA	SELL	MARKET	NA	CLI	MIS	DAY	WC5758	NA	3	NA
4	NSE	EQ	NA	NA	NA	BUY	SL-M		CLI	MIS	DAY	WC5758	NA	NA	NA

	Expected Result
MyTarget	Header3	Header4	Header7
101	H3_1	H4_1	H7_1	first instance
101	H3_5	H4_5	H7_5	second instance
101				third instance (there is no third instance so left empty)
102	H3_2	H4_2	H7_2
103	H3_3	H4_3	H7_3
103	H3_6	H4_6	H7_6
104	H3_8	H4_8	H7_8
108				left empty as there is no 108 in Source
105	H3_7	H4_7	H7_7

Header1	Header3	Header4	Header7
101	H3_1	H4_1	H7_1
102	H3_2	H4_2	H7_2
103	H3_3	H4_3	H7_3
102	H3_4	H4_4	H7_4
101	H3_5	H4_5	H7_5
103	H3_6	H4_6	H7_6
105	H3_7	H4_7	H7_7
104	H3_8	H4_8	H7_8