Results 1 to 10 of 294

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

Threaded View

Previous Post Previous Post   Next Post Next Post
  1. #27
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,316
    Rep Power
    10
    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")  '
    
    Last edited by DocAElstein; 07-20-2020 at 03:14 PM.
    ….If you are my competitor, I will try all I can to beat you. But if I do, I will not belittle you. I will Salute you, because without you, I am nothing.
    If you are my enemy, we will try to kick the fucking shit out of you…..
    Winston Churchill, 1939
    Save your Forum..._
    _...KILL A MODERATOR!!

Similar Threads

  1. Replies: 184
    Last Post: 03-16-2024, 01:16 PM
  2. Tests and Notes for EMail Threads
    By DocAElstein in forum Test Area
    Replies: 29
    Last Post: 11-15-2022, 04:39 PM
  3. Replies: 379
    Last Post: 11-13-2020, 07:44 PM
  4. Appendix Thread. Diet Protokol Coding Adaptions
    By DocAElstein in forum Test Area
    Replies: 6
    Last Post: 09-05-2019, 10:45 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •