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

**DocAElstein** · 07-18-2020, 04:19 PM

Macro for this Post
https://excelfox.com/forum/showthrea...ll=1#post14658
https://excelfox.com/forum/showthrea...ll=1#post14658

Code:

Sub OnlyHaveRowsWhereColumnCisNotEmpty()   '
Rem 1 Workbooks, Worksheets info
                                                                                                                  '     Dim Paf As String: Let Paf = ThisWorkbook.path ' - The path where all workbooks are  CHANGE TO SUIT
Dim arrWbs() As Variant
 Let arrWbs() = Array(ThisWorkbook.path & "\Book1.xlsx", ThisWorkbook.path & "\Book2.xlsx") ' - CHANGE TO SUIT
 Let arrWbs() = Array("C:\Users\WolfieeeStyle\Book1.xlsx", "C:\Users\WolfieeeStyle\Desktop\Book2.xlsx", "C:\Users\Desktop\MyBook.xlsx")  '

Dim Wb As Workbook, Ws As Worksheet
Rem 2 Looping through all files
Dim Stear As Variant
    For Each Stear In arrWbs()
    ' 2a Worksheets data info
     Set Wb = Workbooks.Open(Stear)
                                                                                                                  '     Set Wb = Workbooks.Open(Paf & "\" & Stear)
     Set Ws = Wb.Worksheets.Item(1)
    Dim LrC As Long: Let LrC = Ws.Range("C" & Ws.Rows.Count & "").End(xlUp).Row       ' Dynamically getting the last row in worksheet referenced by  Ws
    Dim arrC() As Variant: Let arrC() = Ws.Range("C1:C" & LrC & "").Value2
    ' 2b row indicies of rows not to be deleted
    Dim Cnt As Long
        For Cnt = 1 To LrC
        Dim strRws As String
            If arrC(Cnt, 1) <> "" Then Let strRws = strRws & Cnt & " "
        Next Cnt
    Let strRws = Left(strRws, Len(strRws) - 1) ' take off last space
    ' 2c Get the indicies in a vertical array, since the  "magic code line"  needs a vertical array
    Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)  ' This gives us a 1 dimensional "horizontal" array  ( starting at indicie 0 )
    Dim RwsT() As Variant: ReDim RwsT(1 To UBound(Rws) + 1, 1 To 1)           ' +1 is needed because the
        For Cnt = 1 To UBound(Rws) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    ' 2d get the output array from "magic code line" :
    Dim Clms() As Variant
     Let Clms() = Evaluate("=Column(A:U)")                                    ' for columns  1 2 3 4 5 6 7 8 9 10 11 12 13 14 125 16 17 18 19 20 21
    Dim arrOut() As Variant
     Let arrOut() = Application.Index(Ws.Cells, RwsT(), Clms())                       '  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
    ' 2e replace worksheet data with modified data arrayOut
     Ws.Cells.ClearContents
     Let Ws.Range("A1").Resize(UBound(arrOut(), 1), 21).Value2 = arrOut()  ' We can paste in one go the contents of an arrasy to a worksheet range
    '2f
     Let strRws = "" ' this is important or else in the next file loop, strRws it will still have values from the last loop
    Next Stear
End Sub

Note: You must change this line

Code:

 Let arrWbs() = Array(ThisWorkbook.path & "\Book1.xlsx", ThisWorkbook.path & "\Book2.xlsx") ' - CHANGE TO SUIT

To something like this

Code:

 Let arrWbs() = Array("C:\Users\WolfieeeStyle\Book1.xlsx", "C:\Users\WolfieeeStyle\Desktop\Book2.xlsx", "C:\Users\Desktop\MyBook.xlsx")  '

**DocAElstein** · 07-19-2020, 12:30 PM

Getting URL for later use of this post

**DocAElstein** · 07-19-2020, 12:31 PM

Macro for this post
https://excelfox.com/forum/showthrea...ll=1#post14664

The two changes for the dynamic column is
_1 a new line
Dim Lc As Long: Let Lc = Ws.UsedRange.Columns.Count - Ws.UsedRange.Column + 1
_2 Modify the column indicia code line, Clms() = Evaluate("=Column(A:U)")
Clms() = Evaluate("=Column(A:" & CL(Lc) & ")")
_3 You need to include the function CL( )

Modified macro and required function, CL( )

Code:

Sub OnlyHaveRowsWhereColumnCisNotEmptyDynamicColumns()   '  https://excelfox.com/forum/showthread.php/2577-Appendix-Thread-(-Codes-for-other-Threads-(-Avinash-)-)?p=14663&viewfull=1#post14663    https://excelfox.com/forum/showthread.php/2577-Appendix-Thread-(-Codes-for-other-Threads-(-Avinash-)-)?p=14657#post14657
Rem 1 Workbooks, Worksheets info
                                                                                                                  '     Dim Paf As String: Let Paf = ThisWorkbook.path ' - The path where all workbooks are  CHANGE TO SUIT
Dim arrWbs() As Variant
 Let arrWbs() = Array(ThisWorkbook.path & "\Book1.xlsx", ThisWorkbook.path & "\Book2.xlsx") ' - CHANGE TO SUIT
' Let arrWbs() = Array("C:\Users\WolfieeeStyle\Book1.xlsx", "C:\Users\WolfieeeStyle\Desktop\Book2.xlsx", "C:\Users\Desktop\MyBook.xlsx")  '

Dim Wb As Workbook, Ws As Worksheet
Rem 2 Looping through all files
Dim Stear As Variant
    For Each Stear In arrWbs()
    ' 2a Worksheets data info
     Set Wb = Workbooks.Open(Stear)
                                                                                                                  '     Set Wb = Workbooks.Open(Paf & "\" & Stear)
     Set Ws = Wb.Worksheets.Item(1)
    Dim LrC As Long: Let LrC = Ws.Range("C" & Ws.Rows.Count & "").End(xlUp).Row       ' Dynamically getting the last row in worksheet referenced by  Ws
    Dim Lc As Long: Let Lc = Ws.UsedRange.Columns.Count - Ws.UsedRange.Column + 1     ' Dynamically getting the last column for the used range in Ws
    Dim arrC() As Variant: Let arrC() = Ws.Range("C1:C" & LrC & "").Value2
    ' 2b row indicies of rows not to be deleted
    Dim Cnt As Long
        For Cnt = 1 To LrC
        Dim strRws As String
            If arrC(Cnt, 1) <> "" Then Let strRws = strRws & Cnt & " "
        Next Cnt
    Let strRws = Left(strRws, Len(strRws) - 1) ' take off last space
    ' 2c Get the indicies in a vertical array, since the  "magic code line"  needs a vertical array
    Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)  ' This gives us a 1 dimensional "horizontal" array  ( starting at indicie 0 )
    Dim RwsT() As Variant: ReDim RwsT(1 To UBound(Rws) + 1, 1 To 1)           ' +1 is needed because the
        For Cnt = 1 To UBound(Rws) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    ' 2d get the output array from "magic code line" :
    Dim Clms() As Variant
'     Let Clms() = Evaluate("=Column(A:U)")                                    ' for columns  1 2 3 4 5 6 7 8 9 10 11 12 13 14 125 16 17 18 19 20 21
     Let Clms() = Evaluate("=Column(A:" & CL(Lc) & ")")
    Dim arrOut() As Variant
     Let arrOut() = Application.Index(Ws.Cells, RwsT(), Clms())                       '  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
    ' 2e replace worksheet data with modified data arrayOut
     Ws.Cells.ClearContents
     Let Ws.Range("A1").Resize(UBound(arrOut(), 1), 21).Value2 = arrOut()  ' We can paste in one go the contents of an arrasy to a worksheet range
    '2f
     Let strRws = "" ' this is important or else in the next file loop, strRws it will still have values from the last loop
    Next Stear
End Sub
 
 ' https://excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort-Last-Row?p=7214#post7214
Public Function CL(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 CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

macro1.xlsm : https://app.box.com/s/tl3rs9693jwuv9c2w36ok8fpaewuf0ta
macro2.xlsm : https://app.box.com/s/t35238lm19bj6y0p6m6p68uaknsdf37z

**DocAElstein** · 07-19-2020, 06:50 PM

For later use

**DocAElstein** · 07-19-2020, 06:51 PM

Macro for this post
https://excelfox.com/forum/showthrea...ll=1#post14675

Code:

Sub DecimalPlaceAdjustment()
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook
 Set Wb1 = Workbooks("1.xls")  '          ' CHANGE TO SUIT
 Set Wb2 = Workbooks("sample2.xlsx")
Dim Ws1 As Worksheet
 Set Ws1 = Wb1.Worksheets.Item(1)
Dim Ws2 As Worksheet
 Set Ws2 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long, Lr2 As Long
 Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count).End(xlUp).Row      '   http://www.excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=11466&viewfull=1#post11466      Making Lr dynamic ( using rng.End(XlUp) for a single column. )
 Let Lr2 = Ws2.Range("A" & Ws1.Rows.Count).End(xlUp).Row
Dim arr1I() As Variant, arr2B() As Variant, arr2E() As Variant, arr1H() As Variant ' , arr1G() As Variant
 Let arr2B() = Ws2.Range("B1:B" & Lr2 & "").Value2
' Let arr1G() = Ws1.Range("G1:G" & Lr2 & "").Value2
 Let arr1I() = Ws1.Range("I1:I" & Lr1 & "").Value2
 Let arr2E() = Ws2.Range("E1:E" & Lr2 & "").Value2
 Let arr1H() = Ws1.Range("H1:H" & Lr1 & "").Value2
Rem 2 ' Do it
Dim Cnt
    For Cnt = 2 To Lr1 ' going through data down column I , Ws1
    '2a check for match data from column I Ws1 in column B Ws2
    Dim MtchRes As Variant
     Let MtchRes = Application.Match(arr1I(Cnt, 1), arr2B(), 0)
        If Not IsError(MtchRes) Then ' If MtchRes did not error then it tells us where  along  the match was found
        Dim LHInt As Long: Let LHInt = Len(Int(arr1H(Cnt, 1))) ' character Length of the integer of the value in H
         Let arr2E(MtchRes, 1) = Replace(arr2E(MtchRes, 1), ".", "", 1, 1, vbBinaryCompare) ' remove any decimal place in the matched row in 2.xlsx in column E
         Let arr2E(MtchRes, 1) = Left(arr2E(MtchRes, 1), LHInt) & "." & Mid(arr2E(MtchRes, 1), LHInt + 1)
        Else
        ' No match was found , so do nothing
        End If
    Next Cnt
Rem 3 Change column E in sample2.xlsx
 Let Ws2.Range("E1:E" & Lr2 & "").Value2 = arr2E()
End Sub

**DocAElstein** · 07-26-2020, 01:21 PM

Notes in support of this Thread
https://excelfox.com/forum/showthrea...between-sheets

We are using the code line like
Index(Cells, Rws(), Clms)

This requires the array of required row numbers from the original worksheet, held in Rws()

These show the Row numbers concerned

Original range. ( First Worksheet Before )
_____ Workbook: 1.xls ( Using Excel 2007 32 bit )

Rows in Original	Original	A	B	C	D	E	F	G	H	I	J	K
R1	1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
R2	2	NSE	ACC	EQ	1265	1265	1246.5	1275.3	1247	22	BUY	1167.6105
R3	3	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25	BUY	141.0465
R4	4	NSE	HDFC	EQ	1805	1826	1805	1809.3	1786.05	1330	BUY	1624.0295
R5	5	NSE	HDFCBANK	EQ	985	988.4	970	991.85	971.85	1333	BUY	854.6115
R6	6	NSE	HEROMOTOCO	EQ	2316	2345	2300	2292.25	2311.8	1348	SHORT	2024.154
R7	7	NSE	HINDALCO	EQ	145.9	147.45	142.45	146.95	143.6	1363	BUY	119.9375

Worksheet: 1-Sheet1 Output 17-21 July

First worksheet After:

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

Rows in Original

First Worksheet After

A

B

C

D

E

F

G

H

I

J

K

R1

1

Exchange

Symbol

Series/Expiry

Open

High

Low

Prev Close

LTP

R2

2

NSE

ACC

EQ

1265

1246.5

1275.3

1247

22

BUY

1167.6105

R4

3

NSE

HDFC

EQ

1805

1826

1805

1809.3

1786.05

1330

BUY

1624.0295

Worksheet: 1-Sheet1 Output 17-21 July

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

Rows in Original	New Sheet		B	C	D	E	F	G	H	I	J	K
R1	1	Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
R3	2	NSE	ADANIENT	EQ	151.85	165.45	151.4	151.85	152.35	25	BUY	141.0465
R5	3	NSE	HDFCBANK	EQ	985	988.4	970	991.85	971.85	1333	BUY	854.6115
R6	4	NSE	HEROMOTOCO	EQ	2316	2345	2300	2292.25	2311.8	1348	SHORT	2024.154
R7	5	NSE	HINDALCO	EQ	145.9	147.45	142.45	146.95	143.6	1363	BUY	119.9375

Worksheet: 1-Sheet1 Output 17-21 July

**DocAElstein** · 07-26-2020, 01:21 PM

Macro solution for these posts

https://excelfox.com/forum/showthrea...between-sheets
https://www.excelforum.com/excel-pro...en-sheets.html
http://www.eileenslounge.com/viewtop...bf154f#p271799

Code:

Sub MoveSomeDataRowsToNewWorksheetBasedOnConditions()
Rem 1 worksheets data info
Dim Wb1 As Workbook
 Set Wb1 = Workbooks("1.xls")
Dim Ws1 As Worksheet
 Set Ws1 = Wb1.Worksheets.Item(1)
Dim Lr1 As Long: Let Lr1 = Ws1.Range("A" & Ws1.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  https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=14565&viewfull=1#post14565
Dim arr1DEF() As Variant
 Let arr1DEF() = Ws1.Range("D1:F" & Lr1 & "").Value2
Rem 2 Get the row numbers wanted in the New worksheet and in the first worksheet after
'2a(i) Build the string indicies based on the criterias
Dim str1 As String, str2 As String '  strings to build for  Row numbers  for the two sheets after
 Let str1 = "1": Let str2 = "1"    '  Both Worksheets should have the headers
Dim Cnt
    For Cnt = 2 To Lr1 Step 1
        If arr1DEF(Cnt, 1) = arr1DEF(Cnt, 2) Or arr1DEF(Cnt, 1) = arr1DEF(Cnt, 3) Then '
         ' Do nothing .. For this macro I want to add here the rows which will still be there in the original worksheet  After
         Let str1 = str1 & " " & Cnt
        Else
        '   ..........."...put that data into new worksheet by creating a new sheet in it & remove that data from current sheet........"
         Let str2 = str2 & " " & Cnt ' this will be used for the new worksheet  It is not being used for the first Worksheet after. So that will mean that these rows do not appear in the first worksheet after  ClearContentsing it
        End If
    Next Cnt
'2a(ii)
Dim Rws1() As String, Rws2() As String
 Let Rws1() = Split(str1, " ", -1, vbBinaryCompare): Let Rws2() = Split(str2, " ", -1, vbBinaryCompare)
'2b) Make the "virtical" row indicie array needed in the  "Magic code line"
Dim RwsV1() As String: ReDim RwsV1(1 To UBound(Rws1()) + 1, 1 To 1): Dim RwsV2() As String: ReDim RwsV2(1 To UBound(Rws2()) + 1, 1 To 1)
    For Cnt = 1 To UBound(Rws1()) + 1  '  +1 is needed because the array returned by  Split  is a 1D array starting at 0
     Let RwsV1(Cnt, 1) = Rws1(Cnt - 1)
    Next Cnt
    For Cnt = 1 To UBound(Rws2()) + 1  '  +1 is needed because the array returned by  Split  is a 1D array starting at 0
     Let RwsV2(Cnt, 1) = Rws2(Cnt - 1)
    Next Cnt
Rem 3 Output
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:K)") ' ** CHANGE TO SUIT ** This is currently for columns A B C ...K  1 2 3..... 11  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
'3a new Worksheet
 Worksheets.Add After:=Worksheets.Item(1)
 Let ActiveSheet.Name = "New Worksheet"
Dim arrOut() As Variant: Let arrOut() = Application.Index(Ws1.Cells, RwsV2(), 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
 Let Worksheets("New Worksheet").Range("A1").Resize(UBound(arrOut(), 1), 11).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()
'3b) Original worksheet after
 Let arrOut() = Application.Index(Ws1.Cells, RwsV1(), 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
'Ws1.UsedRange.ClearContents
Ws1.Range("A1:K" & Lr1 & "").ClearContents
 Let Ws1.Range("A1").Resize(UBound(arrOut(), 1), 11).Value2 = arrOut()
End Sub

**DocAElstein** · 07-26-2020, 01:23 PM

Macro for this post
https://excelfox.com/forum/showthrea...4598#post14598

Code:

'    Copy row from one workbook to another workbook  based on conditions in another Workbooks
'    https://excelfox.com/forum/showthread.php/2583-Macro-Correction

'    https://excelfox.com/forum/showthread.php/2583-Copy-row-from-one-workbook-to-another-workbook-based-on-conditions-in-another-Workbooks

Sub CopyRow1orRow3fromoneworkbooktoanotherworkbookbasedonconditionsinanotherWorkbooks() '
Rem 1 worksheets info
Dim Ws1 As Worksheet, WsOF As Worksheet, WsBO As Worksheet
 Set Ws1 = Workbooks("1.xls").Worksheets.Item(1): Set WsBO = Workbooks("BasketOrder.xlsx").Worksheets.Item(1): Set WsOF = Workbooks("OrderFormat.xlsx").Worksheets.Item(1)
Dim Lr1 As Long: Let Lr1 = Ws1.Range("A" & Ws1.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  https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=14565&viewfull=1#post14565
Dim arr1D() As Variant, arr1H() As Variant
 Let arr1D() = Ws1.Range("D1:D" & Lr1 & "").Value2: Let arr1H() = Ws1.Range("H1:H" & Lr1 & "").Value2   '
Rem 2 Do it ...
'2a We want the rows Row 1 or Row 3 in a "virtical" array
Dim RwsV() As String: ReDim RwsV(1 To Lr1 - 1, 1 To 1) ' I column 2 Dimensional Array
Dim Cnt
    For Cnt = 1 To UBound(RwsV(), 1) ' we want a row indicie of  1  or  3  for each  row to be pased to BasketOrder.xlsx
        If arr1H(Cnt + 1, 1) > arr1D(Cnt + 1, 1) Then     ' If column H of 1.xls is greater than column D of 1.xls then
         Let RwsV(Cnt, 1) = "3"                           ' third row of orderformat.xlsx
        ElseIf arr1H(Cnt + 1, 1) < arr1D(Cnt + 1, 1) Then ' If column H of 1.xls is smaller than column D of 1.xls
         Let RwsV(Cnt, 1) = "1"                           ' first row of orderformat.xlsx
        Else
        
        End If
    Next Cnt
Rem 3 output
Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:U)") ' ** CHANGE TO SUIT ** This is currently for columns A B C ...U  1 2 3..... 21  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(WsOF.Cells, RwsV(), 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
 Let WsBO.Range("A1").Resize(Lr1 - 1, 21).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()
End Sub