Tests Copying, Pasting, API Cliipboard issues. and Rough notes on Advanced API stuff

Test blog post, and function needed for other posts…


http://www.excelfox.com/forum/showth...ge40#post12673

Title….

I have sometimes needed to check for a specific file type in a list of files and folders. Often a simple search for the characters in the extension, ( for example .doc for a Word 2003 file )
I had a more difficult situation where with multiple file types and folders which included parts in the text string which could be mistakenly found in a search fir the extension part.

The logic behind the simple functions below is as follows.
A string is taken in, strIn.
The function contains a list of all extensions being searched for. If an extension is found in the supplied string, then that extension is the string returned by the function. ( The first character in the extension string will always be a . )
If no match is found then the string of
“0” & strIn ' note: that first character is a zero
is retuned

Notes:
In the list, the longest character length extension are at the beginning. This avoids a part of the longer character extension being mistaken as a shorter character extension, since the longest character length extensions will be detected firstly .

Code:

---

Sub TestieGetMyExtension()
 MsgBox prompt:=GetMyExtension("a")
 MsgBox prompt:=GetMyExtension("1394ohci.sys")
 MsgBox prompt:=GetMyExtension("61883.inf_amd64_fb51a2f8b89aa4a7")
 MsgBox prompt:=GetMyExtension("wiaky003.inf_loc")
 MsgBox prompt:=GetMyExtension("acpi.PNF")
 MsgBox prompt:=GetMyExtension("bcmwdidhdpcie.inf_amd64_977dcc915465b0e9")

End Sub
Public Function GetMyExtension(ByVal strIn As String) As String
Dim MyExts() As Variant
 Let MyExts() = Array("inf_loc", "sys.mui", "dll.mui", "sys", "dll", "bin", "cpa", "bag", "xml", "gdl", "cab", "ini", "cat", "inf", "pnf", "gpd", "exe", "sam", "hlp", "ntf", "ppd", "tbl", "icc", "dat", "dpb", "cty", "msc", "xst", "vp", "js")
Dim Stear As Variant
    For Each Stear In MyExts()
    Dim Lenf As Long: Let Lenf = Len(Stear)
        If Len(strIn) > Lenf + 1 Then ' Length of  strIn  must be at least 2 more characters longer than the extension from the array above ,  like  x.sys  so greater than the length of like the length of  .sys  which has the length of  (length of  sys )+1
        Dim LstBt As String
        Let LstBt = Right(strIn, Lenf)
            If "." & UCase(LstBt) = "." & UCase(Stear) Then
            Let GetMyExtension = Stear
            Exit Function ' end of function with sucessful file type find - give file type to  function return string value
            Else
            ' not this file type in last characters
            End If
        Else
        ' then input string is too short to include the current extension string in  Stear
        End If
    Next Stear
 Let GetMyExtension = "0" & strIn ' This allows a simple check for like  If Left(GetMyExstension(kjshdkjs,kiafh_.kjfh, 1)= 0 Then  to determine if we have a file type like we want
End Function


---

Code:

---

Sub CountMissingFilesFromOriginalInNewList2()
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") '    =ANZAHL2(H3:J4396)    =ANZAHL2(D3:F4396)
Dim RngDS1 As Range, RngDS2 As Range  '
 Set RngDS1 = WsDS.Range("G3:J4396"): Set RngDS2 = WsDS.Range("C3:F4396") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020

Dim Cnt1 As Long, cnt2 As Long, Rng As Range, strRej As String
    For Each Rng In RngDS1
        If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 And Not Left(GetMyExtension(Rng.Value), 1) = "0" Then
        ' Not empty cell  And  No interior colour And  any file extension
        Let Cnt1 = Cnt1 + 1
        Else
            If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 Then
            Let strRej = strRej & Rng.Value & vbCr & vbLf
            Let cnt2 = cnt2 + 1
            Else
            End If
        End If
    Next Rng
 MsgBox prompt:="Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not coloured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
 Debug.Print "Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not colured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
End Sub
Sub CountNewFilesFromInNewList2()
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020") '    =ANZAHL2(H3:J4396)    =ANZAHL2(D3:F4396)
Dim RngDS1 As Range, RngDS2 As Range  '
 Set RngDS1 = WsDS.Range("G3:J4396"): Set RngDS2 = WsDS.Range("C3:F4396") ' A bit back to front 1 is right columns original , 2 is left columns new from Marz 2020

Dim Cnt1 As Long, cnt2 As Long, Rng As Range, strRej As String, strNew As String
    For Each Rng In RngDS2
        If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 And Not Left(GetMyExtension(Rng.Value), 1) = "0" Then
        ' conditions to be met are  not empty  And  no interior colour  And  any file extension
        Let Cnt1 = Cnt1 + 1
        Let strNew = strNew & Rng.Value & vbCr & vbLf
        Else
            If Not Rng.Value = "" And Rng.Interior.ColorIndex = -4142 Then
            Let strRej = strRej & Rng.Value & vbCr & vbLf
            Let cnt2 = cnt2 + 1
            Else
            End If
        End If
    Next Rng
 MsgBox prompt:="New is  " & Cnt1 & vbCr & vbLf & "New are  " & strNew
 Debug.Print "New is  " & Cnt1 & vbCr & vbLf & "New are  " & strNew
' MsgBox prompt:="Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not coloured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
' Debug.Print "Missing is  " & Cnt1 & vbCr & vbLf & vbCr & vbLf & "Not counted, not colured: " & vbCr & vbLf & strRej & vbCr & vbLf & "Changed Folder names is  " & cnt2
End Sub

---

ExplorerBefore DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/oy8pnuizk6xng1msqlsxho7l8e0bi0t8
Explorer Before DriverStore Comparison Marz 2020.xlsm : https://app.box.com/s/4zx7b8d2gwjix7u68zit6o22x7q0kwm2

In support of this post
http://www.excelfox.com/forum/showth...ge41#post12675
First use of Dictionary alternative.
The following two macros give similar results. The first is the big Case Else macro and the second the first use of a Dictionary, Dik, alternative.

Code:

---

Option Explicit
' Marz 2020
Private Sub FileTypesHere_And_MaybeAlsoInDeviceManager()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim Rng As Range: Set Rng = Ws.Range("D4:E300") 'Set Rng = Ws.Range("F4:G300") ' Set Rng = Ws.Range("D4:E75")
'Dim arrFiles() As Variant: Let arrFiles() = Rng.Value2
Rem 2 File extension types
Dim Ddl As Long, Sys As Long, Bin As Long, Cpa As Long, Vp As Long, Els As Long
Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long
Dim Cat As Long, Inf As Long, Pnf As Long, Gpd As Long, Exe As Long
Dim Ddl2 As Long, Sys2 As Long, Bin2 As Long, Cpa2 As Long, Vp2 As Long
Dim Bag2 As Long, Xml2 As Long, Js2 As Long, Gdl2 As Long, Cab2 As Long, Ini2 As Long
Dim Cat2 As Long, Inf2 As Long, Pnf2 As Long, Gpd2 As Long, Exe2 As Long
Dim Dpb As Long, Ppd As Long
Dim Dpb2 As Long, Ppd2 As Long
Rem 3 Looping
Dim ClCnt As Long, RwCnt As Long
Dim rngStr As Range
    For Each rngStr In Rng
'    For RwCnt = 1 To UBound(arrFiles(), 1)
'        For ClCnt = 1 To UBound(arrFiles(), 2)
            'If arrFiles(RwCnt, ClCnt) = "" Then
            If rngStr.Value = "" Then
            ' Empty cell, so do nothing
            Else ' Time to look at cell value
'                If Left(arrFiles(RwCnt, ClCnt), 3) = "C:\" And InStr(4, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
                'If InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
                If InStr(2, rngStr.Value, ".", vbBinaryCompare) > 1 Then ' use some criteria to check we have a file path
                ' Get the extension
                Dim Xtn As String
                'Let Xtn = Mid(arrFiles(RwCnt, ClCnt), (InStr(2, arrFiles(RwCnt, ClCnt), ".", vbBinaryCompare) + 1))
                Let Xtn = Mid(rngStr.Value, (InStr(2, rngStr.Value, ".", vbBinaryCompare) + 1))
                    Select Case UCase(Xtn)
                    Case "SYS"
                      Let Sys = Sys + 1: If rngStr.Font.Color <> 0 Then Let Sys2 = Sys2 + 1
                    Case "DLL"
                      Let Ddl = Ddl + 1: If rngStr.Font.Color <> 0 Then Let Ddl2 = Ddl2 + 1
                    Case "BIN"
                      Let Bin = Bin + 1: If rngStr.Font.Color <> 0 Then Let Bin2 = Bin2 + 1
                    Case "CPA"
                      Let Cpa = Cpa + 1: If rngStr.Font.Color <> 0 Then Let Cpa2 = Cpa2 + 1
                    Case "VP"
                      Let Vp = Vp + 1: If rngStr.Font.Color <> 0 Then Let Vp2 = Vp2 + 1
                    'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
                    Case "BAG"
                      Let Bag = Bag + 1: If rngStr.Font.Color <> 0 Then Let Bag2 = Bag2 + 1
                    Case "XML"
                      Let Xml = Xml + 1: If rngStr.Font.Color <> 0 Then Let Xml2 = Xml2 + 1
                    Case "JS"
                      Let Js = Js + 1: If rngStr.Font.Color <> 0 Then Let Js2 = Js2 + 1
                    Case "GDL"
                      Let Gdl = Gdl + 1: If rngStr.Font.Color <> 0 Then Let Gdl2 = Gdl2 + 1
                    Case "CAB"
                      Let Cab = Cab + 1: If rngStr.Font.Color <> 0 Then Let Cab2 = Cab2 + 1
                    Case "INI"
                      Let Ini = Ini + 1: If rngStr.Font.Color <> 0 Then Let Ini2 = Ini2 + 1
                    Case "CAT"
                      Let Cat = Cat + 1: If rngStr.Font.Color <> 0 Then Let Cat2 = Cat2 + 1
                    ' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
                    Case "INF"
                      Let Inf = Inf + 1: If rngStr.Font.Color <> 0 Then Let Inf2 = Inf2 + 1
                    Case "PNF"
                      Let Pnf = Pnf + 1: If rngStr.Font.Color <> 0 Then Let Pnf2 = Pnf2 + 1
                    Case "GPD"
                      Let Gpd = Gpd + 1: If rngStr.Font.Color <> 0 Then Let Gpd2 = Gpd2 + 1
                    Case "EXE"
                      Let Exe = Exe + 1: If rngStr.Font.Color <> 0 Then Let Exe2 = Exe2 + 1
                    ' Dim Dpb As Long, Ppd As Long
                    Case "DPB"
                      Let Dpb = Dpb + 1: If rngStr.Font.Color <> 0 Then Let Dpb2 = Dpb2 + 1
                    Case "PPD"
                      Let Ppd = Ppd + 1: If rngStr.Font.Color <> 0 Then Let Ppd2 = Ppd2 + 1
                    Case Else
                      Debug.Print "Case Else  " & rngStr.Value ' arrFiles(RwCnt, ClCnt)
                      Let Els = Els + 1
                    End Select
                Else ' not a file path, or rather not a  .  in
                Dim Fldr As Long: Let Fldr = Fldr + 1
                End If
            End If
'        Next ClCnt
'    Next RwCnt
    Next rngStr
Rem 4 output
Debug.Print "sys  " & Sys & " (" & Sys2 & ")"
Debug.Print "dll  " & Ddl & " (" & Ddl2 & ")"
Debug.Print "bin  " & Bin & " (" & Bin2 & ")"
Debug.Print "cpa  " & Cpa & " (" & Cpa2 & ")"
Debug.Print "vp  " & Vp & " (" & Vp2 & ")"
Debug.Print "els  " & Els
'Dim Bag As Long, Xml As Long, Js As Long, Gdl As Long, Cab As Long, Ini As Long, Cat As Long
Debug.Print "bag  " & Bag & " (" & Bag2 & ")"
Debug.Print "xml  " & Xml & " (" & Xml2 & ")"
Debug.Print "js  " & Js & " (" & Js2 & ")"
Debug.Print "gdl  " & Gdl & " (" & Gdl2 & ")"
Debug.Print "cab  " & Cab & " (" & Cab2 & ")"
Debug.Print "ini  " & Ini & " (" & Ini2 & ")"
Debug.Print "cat  " & Cat & " (" & Cat2 & ")"
' Inf As Long, Pnf As Long, Gpd As Long, Exe as long
Debug.Print "inf  " & Inf & " (" & Inf2 & ")"
Debug.Print "pnf  " & Pnf & " (" & Pnf2 & ")"
Debug.Print "gpd  " & Gpd & " (" & Gpd2 & ")"
Debug.Print "exe  " & Exe & " (" & Exe2 & ")"
' Dim Dpb As Long, Ppd As Long
Debug.Print "dpb  " & Dpb & " (" & Dpb2 & ")"
Debug.Print "ppd  " & Ppd & " (" & Ppd2 & ")"
Debug.Print "Total files is  " & Sys + Ddl + Bin + Cpa + Vp + Bag + Xml + Js + Gdl + Cab + Ini + Cat + Inf + Pnf + Gpd + Exe + Dpb + Ppd
Debug.Print "Things with no  .  are  " & Fldr
End Sub

Private Sub FilesTypeHereFromFunction()
Rem 1 Worksheets info
Dim Ws As Worksheet: Set Ws = Me
Dim rng2BSrchd As Range: Set rng2BSrchd = Ws.Range("D4:E260")
Rem 2 A Dik for the extensions and count thereof
'2a) Make the Dik
Dim Dik As Object: Set Dik = CreateObject("Scripting.Dictionary")
Dik.CompareMode = vbTextCompare ' make case insensitive, probably not necersary in our case as we do all comares at UCase to make it already case insensitive
'2b) Fill the Dik
Dim rngStr As Range
    For Each rngStr In rng2BSrchd
        If rngStr.Value = "" Then
        ' empty cell  Do nothing
        Else
        Dim FkBk As String
        Let FkBk = GetMeExtension(Trim(rngStr.Value))
            If Left(FkBk, 1) = "0" Then
            Dim Fldrs As String
            Let Fldrs = Fldrs & rngStr.Value & vbCr & vbLf
            Else ' we have an extension of a type we may or may not have had already
                If Dik.Exists("" & FkBk & "") Then
                Let Dik.Item("" & FkBk & "") = Dik.Item("" & FkBk & "") + 1 ' add to count of this extension, - the count is actually held as the item
                Else
                Dik.Add Key:="" & FkBk & "", Item:=1 ' I create an item who's key is the extension string, and make item the count of it,  1 here initially
                End If
            End If
        End If
   
    Next rngStr
'2c) output from Dik
Dim Kys() As Variant, Itms() As Variant
 Let Kys() = Dik.Keys(): Let Itms() = Dik.Items()
Dim Cnt As Long
    For Cnt = 0 To Dik.Count - 1 ' Note Dictionaries by default start at 0, but the count is the actual number, so  Count-1  is the last indicee and  0  is the first
    Debug.Print Kys()(Cnt) & " " & Itms()(Cnt)
    Next Cnt

End Sub

---

In support of this post
http://www.excelfox.com/forum/showth...ge41#post12675

Code:

---

'  http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12675
Sub NewCmdVNewDD()  '    http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
 Set Rngcmd = Wscmd.Range("D4:E260")
    If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim WsDD As Worksheet: Set WsDD = Worksheets("DDAllComparison")
Dim RngDD As Range
 Set RngDD = WsDD.Range("E4:E680")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
    For Each Rng In Selection
        If Rng <> "" Then
        Dim FndRng As Range ' range file cell found in DD
        Set FndRng = RngDD.Find(what:=Rng.Value, After:=RngDD.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
            If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
                Wscmd.Activate: Rng.Select
                Let Rng.Font.ColorIndex = ClrIdx
                Application.Wait (Now + TimeValue("00:00:01"))
                   
                    Do While Not FndRng Is Nothing
                    WsDD.Activate: FndRng.Select
                    Let FndRng.Font.ColorIndex = ClrIdx
                    Application.Wait (Now + TimeValue("00:00:01"))
                    Set FndRng = WsDD.Range("E" & FndRng.Row + 1 & ":E680").Find(what:=Rng.Value, After:=WsDD.Range("E680"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '  https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
                  Loop ' looping for next match ======
            Else ' no cell value match
            End If
        Else ' case rng has not text in it
        End If
    Next Rng  ' Each Rng In RngDD ---------------|
End Sub


---

Macro for this post solution, ( written by the son of God )
http://www.excelfox.com/forum/showth...ll=1#post12897

Code:

---

Sub conditionally_delete3() '  http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-entire-row?p=12893&viewfull=1#post12893
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
 Set Wb1 = Workbooks("STEP1U.xlsb") ' Workbooks("sample1.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Upstox\STEP1U.xlsb")
 Set Ws1 = Wb1.Worksheets.Item(1) ' worksheet of first tab
 Set Wb2 = Workbooks("1.xls") ' Workbooks("sample2.xlsx") '  Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
 Set Ws2 = Wb2.Worksheets.Item(1) ' worksheet of first tab
'1b Ranges
Dim Rng1A As Range, Rng2B As Range
 Set Rng1A = Ws1.Range("A2:A" & Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row & "")
 Set Rng2B = Ws2.Range("B2:B" & Ws2.Range("B" & Ws2.Rows.Count & "").End(xlUp).Row & "")

Rem 2 Delete an entire row in Ws2 if value in column B is not anywhere in column A of Ws1
Dim Rws As Long
    For Rws = Ws2.Range("B" & Ws2.Rows.Count & "").End(xlUp).Row To 2 Step -1
    Dim rngFnd As Range
    Set rngFnd = Rng1A.Find(what:=Ws2.Range("B" & Rws & "").Value, After:=Rng1A.Item(1), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '  https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
        If rngFnd Is Nothing Then ' The value from column B in Ws2 was not found in column A of Ws1
        Ws2.Range("B" & Rws & "").EntireRow.Delete Shift:=xlUp
        Else
        ' The value from column B in Ws2 was found in column A of Ws1 so do nothing
        End If
    Next Rws
   
'    Wb1.Save
'    Wb1.Close
'    Wb2.Save
'    Wb2.Close
End Sub

---

---

1.xls: https://app.box.com/s/th2xzmkh7rnfr4qf4dho1kpgudndm073

In support of these posts

http://www.excelfox.com/forum/showth...ge41#post12676
http://www.excelfox.com/forum/showth...ge41#post12677
http://www.excelfox.com/forum/showth...ge41#post12678

Code:

---

'  http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12676
Sub NewCmdVNewDD()  '    http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
 Set Rngcmd = Wscmd.Range("D4:E260")
    If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim WsDD As Worksheet: Set WsDD = Worksheets("DDAllComparison")
Dim RngDD As Range
 Set RngDD = WsDD.Range("E4:E680")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
    For Each Rng In Selection
        If Rng <> "" Then
        Dim FndRng As Range ' range file cell found in DD
        Set FndRng = RngDD.Find(what:=Rng.Value, After:=RngDD.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
            If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
                Wscmd.Activate: Rng.Select
                Let Rng.Font.ColorIndex = ClrIdx
                Application.Wait (Now + TimeValue("00:00:01"))
                   
                    Do While Not FndRng Is Nothing
                    WsDD.Activate: FndRng.Select
                    Let FndRng.Font.ColorIndex = ClrIdx
                    Application.Wait (Now + TimeValue("00:00:01"))
                    Set FndRng = WsDD.Range("E" & FndRng.Row + 1 & ":E680").Find(what:=Rng.Value, After:=WsDD.Range("E680"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '  https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
                  Loop ' looping for next match ======
            Else ' no cell value match
            End If
        Else ' case rng has not text in it
        End If
    Next Rng  ' Each Rng In RngDD ---------------|
End Sub

'  http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12677
Sub NewCmdVNewdrivers()  '    http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
 Set Rngcmd = Wscmd.Range("E4:F260")
    If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim Wsdrs As Worksheet: Set Wsdrs = Worksheets("drivers marz 2020")
Dim Rngdrs As Range
 Set Rngdrs = Wsdrs.Range("D6:E180")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
    For Each Rng In Selection
        If Rng <> "" Then
        Dim FndRng As Range ' range file cell found in DD
        Set FndRng = Rngdrs.Find(what:=Rng.Value, After:=Rngdrs.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
            If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
                Wscmd.Activate: Rng.Select
                Let Rng.Font.ColorIndex = ClrIdx
                Application.Wait (Now + TimeValue("00:00:01"))
                   
                    Do While Not FndRng Is Nothing
                    Wsdrs.Activate: FndRng.Select
                    Let FndRng.Font.ColorIndex = ClrIdx
                    Application.Wait (Now + TimeValue("00:00:01"))
                    Set FndRng = Wsdrs.Range("D" & FndRng.Row + 1 & ":E180").Find(what:=Rng.Value, After:=Wsdrs.Range("E180"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '  https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
                  Loop ' looping for next match ======
            Else ' no cell value match
            End If
        Else ' case rng has not text in it
        End If
    Next Rng  ' Each Rng In ---- ---------------|
End Sub



'  http://www.excelfox.com/forum/showthread.php/2408-Windows-10-and-Office-Excel/page41#post12678
Sub NewCmdVNewDriverStore()  '    http://www.eileenslounge.com/viewtopic.php?f=55&t=34247#p265646
Dim Wscmd As Worksheet: Set Wscmd = Worksheets("Command17Marz")
Dim Rngcmd As Range ' dont actually need this, since I make a selection.. but I can use it to check the selection
 Set Rngcmd = Wscmd.Range("E4:F260")
    If Intersect(Rngcmd, Selection) Is Nothing Then MsgBox prompt:="oops": Exit Sub
Dim WsDS As Worksheet: Set WsDS = Worksheets("DriverStoreCompareMarz17 2020")
Dim RngDS As Range
 Set RngDS = WsDS.Range("D6:F4395")
Dim ClrIdx As Long: Randomize: Let ClrIdx = (Int(Rnd * 54)) + 3
' take each cell in cmd range and find it in DD range
Dim Rng As Range
    For Each Rng In Selection
        If Rng <> "" Then
        Dim FndRng As Range ' range file cell found in DD
        Set FndRng = RngDS.Find(what:=Rng.Value, After:=RngDS.Cells.Item(1), LookAt:=xlPart, searchorder:=xlNext, MatchCase:=False) '
            If Not FndRng Is Nothing Then ' we have a match that may or may not be the only one in DD, I am assuming it is the only one in cmd, at least in the selection I am using
                Wscmd.Activate: Rng.Select
                Let Rng.Font.ColorIndex = ClrIdx
                Application.Wait (Now + TimeValue("00:00:01"))
                   
                    Do While Not FndRng Is Nothing
                    WsDS.Activate: FndRng.Select
                    Let FndRng.Font.ColorIndex = ClrIdx
                    Application.Wait (Now + TimeValue("00:00:01"))
                    Set FndRng = WsDS.Range("D" & FndRng.Row + 1 & ":F4395").Find(what:=Rng.Value, After:=WsDS.Range("F4395"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)  '  https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
                  Loop ' looping for next match ======
            Else ' no cell value match
            End If
        Else ' case rng has not text in it
        End If
    Next Rng  ' Each Rng In RngDD ---------------|
End Sub


---

http://www.excelfox.com/forum/showth...ll=1#post12897
Test blog

Loop backwards when deleting rows

Important notes in support of these posts: http://www.excelfox.com/forum/showth...ll=1#post12897
https://excelfox.com/forum/showthrea...ire-row-by-vbA
https://excelfox.com/forum/showthrea...wo-excel-files

When deleting rows, ( and when deleting things generally ) , in a Loop, we will usually need to loop backwards.
If we loop backwards, things “behind us” were already considered, and so no strange effects will be noticed if they are effected by further deletions:
If we Loop forwards , rows will shift up after a delete, and so when moving on a row we may miss a row that is needed to be deleted, or other strange effects may occur:
Due to the deletion, things “ahead of us” , which we have not yet considered, may change in some way. The row number or item number, etc., of something not yet considered may change: This can cause VBA to get confused. We may get the wrong results, or worse, cause some coding error:
At the start of a loop, the parameters such as start, stop, and increment are set. Changing these after the loop begins may cause problems. It is generally bad practice to change loop parameters after the loop begins and before the loop ends, especially if those parameters are to be further used before the loop ends.

For example, in the case of deleting things in a looping process, this may sometimes give us problems:

__For Cnt = 1 To 4 Step 1 ' __ 1 2 3 4

Usually, this alternative, would overcome problems:

__For Cnt = 4 To 1 Step -1 ' __ 4 3 2 1

---

Example

We want to delete rows based on value in column C, in the range A1:C4: If the value is Delete this row , then the entire row should be deleted

Before:-

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

Row\Col	A	B	C	D	E	F	G
1	11	a	Do not delete
2	12	B	Delete this row
3	13	c	Delete this row
4	14	D	Do not delete
5
6				Original Range:-
7				11	a	Do not delete
8				12	B	Delete this row
9				13	c	Delete this row
10				14	D	Do not delete
11

Worksheet: MySheet

So in the above example, we want to delete rows 2 and 3.

We could try this macro, but it gives the wrong results. At first glance we would expect it to work.
It loops through the rows, and deletes the row if the value in column C is Delete this row. One could be forgiven for thinking that it should work.

Code:

---

Option Explicit
Sub LoopForwardsToDeleteRows()
Rem 1 Worksheets info
Dim Wb As Workbook, Ws As Worksheet
 Set Wb = ThisWorkbook: Set Ws = Wb.Worksheets.Item(1)

Rem 2 Loop to delete rows
Dim Rws As Long
    For Rws = 1 To 4 '  1 2 3 4
        If Ws.Range("C" & Rws & "").Value = "Delete this row" Then
        Ws.Range("C" & Rws & "").EntireRow.Delete Shift:=xlUp ' Delete entire row, and  Shift  all rows above up to fill space
        Else
        ' Do nothing
        End If
    Next Rws
End Sub

---

After running the above macro we have

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

Row\Col	A	B	C	D	E	F	G
1	11	a	Do not delete
2	13	c	Delete this row
3	14	D	Do not delete
4
5				Original Range:-
6				11	a	Do not delete
7				12	B	Delete this row
8				13	c	Delete this row
9				14	D	Do not delete
10
11

Worksheet: MySheet

This is what goes on:
Nothing is done to the first row. No problems
The second row is deleted as expected, because cell C2 value was Delete this row
After the second row is deleted, the rows which were after the second row, are all shifted one row up so as to fill the space or “hole” left by the removed row. ( We cannot have a “black hole” in an Excel worksheet:. Excel does not allow this. – The spreadsheet cells are moved so as to “fill” the hole made by the deletion. “New” cells are added as necessary at the worksheet perimeter – In this case a new virgin row is added at the bottom of the worksheet )
The result of the second row being deleted, and the necessary shifting of cells to fill the “hole” which is done, is as follows:
Our original 4th row now becomes the 3rd row. That does not cause any problems.
Our original 3rd row now becomes the 2nd row. This is the problem. The second row has already been considered. It will not be considered again. The original 3rd row, ( now, as a result of the first deletion and cell shifting, the second row ) will not be considered. So it remains. It is not considered. It will therefore not be deleted.
When looping forward and deleting, rows not yet considered will be moved: This may cause problems.

The solution to the problem is to loop backwards. When looping backwards, if a row is deleted, then all rows “behind”/ “above” are shifted down. All those rows have already been considered, and either left as they are or deleted.
The next row to be considered, when looping backwards in a worksheet, will always be the next, not yet considered, row, regardless of whether the last row considered was deleted or not: None of the rows not yet considered have been shifted.
When looping backwards and deleting, rows not yet considered will not have been moved

So we try again

Before, ( as in previous example )

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

Row\Col	A	B	C	D	E	F	G
1	11	a	Do not delete
2	12	B	Delete this row
3	13	c	Delete this row
4	14	D	Do not delete
5
6				Original Range:-
7				11	a	Do not delete
8				12	B	Delete this row
9				13	c	Delete this row
10				14	D	Do not delete
11

Worksheet: MySheet

Macro: ( looping backwards )

Code:

---

Sub LoopBackwardsToDeleteRows()
Rem 1 Worksheets info
Dim Wb As Workbook, Ws As Worksheet
 Set Wb = ThisWorkbook: Set Ws = Wb.Worksheets.Item(1)

Rem 2 Loop to delete rows
Dim Rws As Long
    For Rws = 4 To 1 Step -1  '  4 3 2 1
        If Ws.Range("C" & Rws & "").Value = "Delete this row" Then
        Ws.Range("C" & Rws & "").EntireRow.Delete Shift:=xlUp ' Delete entire row, and  Shift  all rows above up to fill space
        Else
        ' Do nothing
        End If
    Next Rws
End Sub

---

After:

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

Row\Col	A	B	C	D	E	F	G
1	11	a	Do not delete
2	14	D	Do not delete
3
4				Original Range:-
5				11	a	Do not delete
6				12	B	Delete this row
7				13	c	Delete this row
8				14	D	Do not delete
9
10
11

Worksheet: MySheet


This time we have the correct results: Looping backwards gives correct results. Looping fowards may give incorrect results.

In support of this Thread
http://www.excelfox.com/forum/showth...the-entire-row

Before

_____ Workbook: sample1.xlsx ( 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	ACC	EQ	1014	1030	955.5	998.45	957.4
3	NSE	ADANIPORTS	EQ	27.35	27.75	25.65	25.65	25.85
4

Worksheet: Tabelle1

_____ Workbook: sample2.xlsx ( 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	ACC	EQ	1014	1030	955.5	998.45	957.4
3	NSE	ADANIPORTS	EQ	27.35	28	29	30	27.35
4

Worksheet: Tabelle2


If column H of sample2.xlsx matches with Column D then look column B data of sample2.xlsx and find that data in sample1.xlsx in column B and after getting that data in sample1.xlsx in column B , copy that entire row of sample1.xlsx and paste that in sample2.xlsx in the same row


Result:

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

Exchange	Symbol	Series/Expiry	Open	High	Low	Prev Close	LTP
NSE	ACC	EQ	1014	1030	955.5	998.45	957.4
NSE	ADANIPORTS	EQ	27.35	27.75	25.65	25.65	25.85

Worksheet: Tabelle2

In support of this Post:
http://www.excelfox.com/forum/showth...ll=1#post13014

Before:

_____ Workbook: sample1.xlsx ( 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	ACC	EQ	1000	1030	955.5	998.45	957.4
3	NSE	ADANIENT	EQ	27.35	27.75	25.65	25.65	25.85
4	NSE	ADANIPORTS	EQ	259	259.6	244	248.2	251.3
5	NSE	ADANIPOWER	EQ	5, 4	5, 5	5, 6	5, 7	5, 8
6	NSE	AMARAJABAT	EQ	459.8	482.25	445.1	439.35	455.35
7	NSE	AMBUJACEM	EQ	7, 4	7, 5	7, 6	7, 7	7, 8
8	NSE	APOLLOHOSP	EQ	8, 4	8, 5	8, 6	8, 7	8, 8
9

Worksheet: anything

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

Row\Col	A
1	SYMBOL
2	ACC
3	ADANIPORTS
4	AMARAJABAT
5

Worksheet: anything

run macro:

Code:

---

'  http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste/page2#post13014  http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014
'  http://www.excelfox.com/forum/showthread.php/2445-copy-and-paste-by-vba          http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste?p=13014&viewfull=1#post13014
Sub STEP6d() ' match column B of sample1.xlsx matches with column A of sample2.xlsx
'              if it matches then copy paste the data from column D to column H to sample2.xlsx from column B
Dim Wb1 As Workbook, Wb2 As Workbook                    '          If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
 Set Wb1 = Workbooks("sample1.xlsx")  '                      Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls")                ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")          ' change the file path  If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
 Set Wb2 = Workbooks("sample2.xlsx")  '                      Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb")      ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path      If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = Wb1.Worksheets("anything")  '    sheet name can be anything
 'Set Ws1 = Wb1.Worksheets.Item(1)
 Set Ws2 = Wb2.Worksheets("anything")
 'Set Ws2 = Wb2.Worksheets.Item(1)
Dim Lr1 As Long, Lr2 As Long  '  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 Lr1 = Ws1.Range("B" & Ws1.Rows.Count).End(xlUp).Row
 Let Lr2 = Ws2.Range("A" & Ws2.Rows.Count).End(xlUp).Row

Dim Cnt As Long
    For Cnt = 2 To Lr2
    Dim FndCel As Range  '  http://www.excelfox.com/forum/showthread.php/2436-conditionally-delete-or-replace-entire-row?p=13007&viewfull=1#post13007
    Dim rngSrch As Range '
    Set rngSrch = Ws1.Range("B2:B" & Lr1 & "")
    Set FndCel = rngSrch.Find(What:=Ws2.Range("A" & Cnt & "").Value, After:=Ws1.Range("B2"), LookIn:=xlValues, LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) '  https://stackoverflow.com/questions/49094391/excel-vba-range-findnext-v-range-find-what-have-i-missed/49181464#49181464
    ' The range to be copied is always offset by 0 rows  and +2 column from the cell found, FndCel,  in column B of sample1.xlsx . Its size will be 1 row and 5 columns
    FndCel.Offset(0, 2).Resize(1, 5).Copy '    copy column D to column H
    ' paste the data from column D to column H to sample2.xlsx from column B
    Ws2.Range("A" & Cnt & "").Offset(0, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    Next Cnt
End Sub

---

After Result:-

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

Row\Col	A	B	C	D	E	F	G
1	SYMBOL
2	ACC	1000	1030	955.5	998.45	957.4
3	ADANIPORTS	259	259.6	244	248.2	251.3
4	AMARAJABAT	459.8	482.25	445.1	439.35	455.35
5

Worksheet: anything

Macro for this Post
' http://www.excelfox.com/forum/showth...ll=1#post13058 http://www.excelfox.com/forum/showth...3058#post13058

Code:

---

'  http://www.excelfox.com/forum/showthread.php/2421-copy-and-paste-by-VBA-based-on-criteria?p=13058&viewfull=1#post13058    http://www.excelfox.com/forum/showthread.php/2454-copy-and-paste-by-vba?p=13058#post13058
Sub Step10()
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook  '                          If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
 Set Wb1 = Workbooks("1.xlsx")        '          Workbooks("sample1.xlsx")  '                                                Set Wb1 = Workbooks.Open(ThisWorkbook.Path & "\1.xls")                ' w1 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")          ' change the file path  If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
 Set Wb2 = Workbooks("2.xlsx")        '          Workbooks("sample2.xlsx")  '                                                Set Wb2 = Workbooks.Open(ThisWorkbook.Path & "\FundsCheck.xlsb")      ' w2 = Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\FundsCheck.xlsb") ' change the file path      If the workbook is already open , then we can refer to it using the workbooks collection object of open workbooks,  Workbooks(" ")
Dim Ws1 As Worksheet, Ws2 As Worksheet
 Set Ws1 = Wb1.Worksheets.Item(1)      '                                                                            Set Ws1 = Wb1.Worksheets("anything")  '    sheet name can be anything
 Set Ws2 = Wb2.Worksheets.Item(1)      '                                                                          ' Set Ws2 = Wb2.Worksheets("anything")
Dim Lr1 As Long, Lc1 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 Lc1 = Ws1.Cells.Item(2, Ws1.Columns.Count).End(xlToLeft).Column
Rem 2 Data ranges
Dim arrOut() As String
 ReDim arrOut(1 To Lr1 - 1, 1 To 2) ' A 2 column array of as many rows as data in 1.xlsx  We may not need all the rows
Dim rngIn As Range
 Set rngIn = Ws1.Range(Ws1.Range("A1"), Ws1.Cells.Item(Lr1, Lc1))
Rem 3 Go through rows and columns  in input data range
Dim Rws As Long
    For Rws = 2 To Lr1 ' Go through rows in input data range
    Dim rngInRws As Range
    Set rngInRws = rngIn.Rows.Item(Rws) ' consider a row in the data range
    Dim Clms As Long ' go through columns in each row
        For Clms = 2 To Lc1 ' considering each column in the row under consideration
            If rngInRws.Cells.Item(Clms).Interior.Color = 65535 And rngInRws.Cells.Item(Clms).Value >= 5 Then ' ...if yellow highlighted colour data is greater than 5 or equal to 5 then
            Dim RwOut As Long ' a row in output array
            Let RwOut = RwOut + 1 ' a next new row in output array
            Let arrOut(RwOut, 1) = rngInRws.Cells.Item(1)              ' The value in the first cell in the row under consideration is put in first column in output array
            Let arrOut(RwOut, 2) = rngInRws.Cells.Item(Clms).Value    ' The value in the highlighted cell in the row under consideration is put in the second column of the output array
            Else
            ' Do nothing
            End If
        Next Clms
    Next Rws
Rem 4 Output result
 Let Ws2.Range("A1:B" & Lr1 - 1 & "").Value = arrOut() ' A range of the dimensions of the output array has its values assigned to the values in the output arry
End Sub


---

In support of this question
https://excelribbon.tips.net/T008884..._Into_One.html

Quote:

---

The full syntax of what Allen Wyatt is using is like …….
Cells(Rows.Count, 1).End(xlUp).Item(2) ……..
….
Item(2) will give us the cell just below the cell given by…….
Cells(Rows.Count, 1).End(xlUp) ………

Cells(Rows.Count, 1).End(xlUp) is the same as Cells(Rows.Count, 1).End(xlUp).Item(1) ………
……….
It is not to easy to explain how the items are assigned for a range……
See this demo

---

In the following demo, I show the item numbers for cells in four arbritrary ranges, A9 , B2:C3 , E5:G5 and D10:D12
As you will see, Item numbers are not restricted to just the range itself. The item numbers keep going. They go in a sequence of ... all columns in a row, ... then the next row ... etc....
The column count is determined by the original range, but the rows are not limited.

Row\Col	A	B	C	D	E	F	G
1
2		Item(1)	Item(2)
3		Item(3)	Item(4)
4		Item(5)	Item(6)
5		Item(7)	Item(8)		Item(1)	Item(2)	Item(3)
6		Item(9)	….etc…		Item(4)	Item(5)	Item(6)
7					Item(7)	Item(8)	Item(9)
8					Item(10)	….etc….
9	Item(1)
10	Item(2)			Item(1)
11	Item(3)			Item(2)
12	Item(4)			Item(3)
13	Item(5)			Item(4)
14	Item(6)			Item(5)
15	…..etc….			Item(6)
16				Item(7)
17				Item(8)
18				Item(9)
19				Item(10)
20				….etc…
21