Appendix Thread. ( Codes for other Threads, ( Avinash ).)

**DocAElstein** · 06-10-2020, 02:09 PM

test ...

test

skjfSKJHFkjhfKJSHFSKJHFskjhf

Different File Types used for simple values
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

Function to make an Excel files from a text file containing values and separators

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 )

The function is almost identical to the macro I did for you here: Code for Text File to Excelhttps://eileenslounge.com/viewtopic.php?p=269105#p269105
The function is here: https://excelfox.com/forum/showthrea...ll=1#post13717

It is a function.
So you will need to call it with a test macro such as this:

Code:

' https://excelfox.com/forum/showthread.php/2519-Convert-Csv-To-Xlsx
Sub Test_MakeXLFileusingvaluesInTextFile()
Dim Pf As String
Let Pf = ThisWorkbook.Path  '                ' CHANGE TO SUIT
'let pf = "C:\Users\WolfieeeStyle\Desktop"   ' CHANGE TO SUIT
 Call MakeXLFileusingvaluesInTextFile(Pf, "sample2BEFORE..csv", "Test.xlsx", ",", vbCr & vbLf)
End Sub

I tested it using this text file: Share ‘sample2BEFORE..csv’ : https://app.box.com/s/a3o4irgofydb71e3o0c4aaxefg6dw3bi
NSE,101010,6,<,12783,A,,,,,GTT
NSE,22,6,<,12783,A,,,,,GTT
NSE,17388,6,<,12783,A,,,,,GTT

Running the test macro results in an Excel File being made looking like this:

_____ Workbook: Test.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	K
1	NSE	101010	6	<	12783	A	GTT
2	NSE	22	6	<	12783	A	GTT
3	NSE	17388	6	<	12783	A	GTT
4

Worksheet: Sheet1

**DocAElstein** · 06-10-2020, 02:09 PM

lKSHFLhlhfl

my testies shit

The biggest problem is..
Since a few weeks you have introduced a new problem for yourself which will help to ensure that you fail in everything: You make many cross post an everyone helping you writes there codes slightly differently. So you are getting into a mixed up chaotic mess of different codlings and are beginning to post many wrong files and incorrect or incomplete macros and explanations of what you want.
You are getting into a mixed up mess

The macro you have posted https://excelfox.com/forum/showthrea...ll=1#post14591 does the following:
It looks for the data values in column I of Ws1 in column B of Ws2. So the range to be searched is column B in Ws2. The values to be searched for are in column I of Ws1
When a matched value is found we look at the value in column D of Ws2 at the row where the match occurred. Based on whether or not we have “>” in that cell we will add or subtract 1% to the value in E in Ws2 at the row of the data being looked at , the value in variable I
This last bit is not what you want
For example, first we look for 22 (from row I=2) in column B of Ws2. That is found in row 1 of Ws2.
So
R2=WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0)=1
In row 2 of Ws2 in the D column is a < so we take the option of
.Cells(I, "K").Value = Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
That code line takes the value in column E at row 2 of Ws1 , which is 200 and adds 1% which is 2, giving you 202, which is not what you want.
But you want it to take the value at the row where the match was found in Ws1, which is 1
That will give the output of 100 +1 = 101

The macro does what you asked for:
If column I of 1.xls matches with column B of Alertcodes.xlsx & column D has < this then calculate the 1% of of column E & add that 1% to column E & the result which will come it will be pasted to column K of 1.xls
If column I of 1.xls matches with column B of Alertcodes.xlsx & column D has > this then calculate the 1% of of column E & subtract that 1% to column E & the result which will come it will be pasted to column K of 1.xls

But what you asked for could mean many things and have many different answers. Your explanation was incomplete. You explanation was very bad.

This was error
Ws2.Cells(i, "E").Value - 0.01 * Ws2.Cells(i, "E").Value
This is correction
Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value

This is what you want:
Question:
Values in column I of 1.xls are to be looked for, ( Matched ) in column B of AlertCodes.xlsx
At the row in 1.xls where the match is found, the matched row, the following is to be done:
Consider the value in column D of 1.xls at the matched row in 1.xls
& If column D has this, < , then calculate the 1% of column E & add that 1% to column E & the result which will come it will be pasted to column K of 1.xls at the matched row
Or else if
& If column D has this, > , then calculate the 1% of column E & subtract that 1% from column E & the result which will come it will be pasted to column K of 1.xls at the matched row

Solution:
Here https://excelfox.com/forum/showthrea...ll=1#post14594

Before:
_____ Workbook: AlertCodes.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	K
1	NSE	22	6	<	100	A	GTT
2	NSE	25	6	<	200	A	GTT
3	NSE	15083	6	<	300	A	GTT

Worksheet: Sheet4 July 13 2020

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

_Row\^Col	A	B	C	D	E	F	G	H	I	J
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	1265	1282.7	1246.5	1275.3	1247	22	BUY
3	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25	BUY
4	NSE	ADANIPORTS	EQ	348	348	338.5	346.55	338.85	15083	BUY

Worksheet: 1-Sheet1 13July

[color=B]After[/B] running macro here https://excelfox.com/forum/showthrea...ll=1#post14594

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

_Row\^Col	A	B	C	D	E	F	G	H	I	J	K
1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
2	NSE	ACC	EQ	1265	1282.7	1246.5	1275.3	1247	22	BUY	101
3	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25	BUY	202
4	NSE	ADANIPORTS	EQ	348	348	338.5	346.55	338.85	15083	BUY	303

Worksheet: 1-Sheet1 13July

Alan

**DocAElstein** · 06-11-2020, 03:22 PM

Just testing links to Threads

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

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

**DocAElstein** · 06-12-2020, 12:52 PM

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

**DocAElstein** · 06-27-2020, 02:58 PM

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

**DocAElstein** · 06-28-2020, 02:37 AM

post to get the URL - for later use

**DocAElstein** · 07-03-2020, 02:47 PM

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

**DocAElstein** · 07-03-2020, 03:16 PM

post to get the URL - for later use

**DocAElstein** · 07-05-2020, 05:07 PM

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

**DocAElstein** · 07-05-2020, 09:39 PM

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