Appendix Thread. 3 *

**DocAElstein** · 07-07-2020, 12:25 PM

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

**DocAElstein** · 07-07-2020, 04:46 PM

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

**DocAElstein** · 07-11-2020, 12:27 AM

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

**DocAElstein** · 07-15-2020, 01:54 PM

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

**DocAElstein** · 07-16-2020, 12:18 PM

test post to get URL for later use

**DocAElstein** · 07-16-2020, 01:48 PM

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

**DocAElstein** · 07-24-2020, 01:59 PM

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

**DocAElstein** · 07-24-2020, 03:12 PM

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

**DocAElstein** · 07-24-2020, 04:21 PM

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