(Solved) – How to combine these two codes without damage?

(solved)-–-how-to-combine-these-two-codes-without-damage?

I would need to combine these two codes, with the file to be able to capture on the various xlsx files of the same folder (name, path, size) as per code1 and a series of cells as per code2. But I tried it myself and it doesn’t work, it upsets all columns.

Code1

Option Explicit

'Important: this Dim line must be at the top of your module
Dim MyFiles As String


Sub TestMacroForThisfileWithCellReferences()
    Dim MySplit As Variant
    Dim FileInMyFiles As Long
    Dim Fstr As String
    Dim LastSep As String

    'Note: I use cell references in this macro to make it easy to test the code
    'Normally you will use it like this :
    'Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="SearchString")

    'Clear MyFiles to be sure that it not return old info if no files are found
    MyFiles = ""

    'Fill the MyFiles string with the files if they match your criteria
    Call GetFilesOnMacWithOrWithoutSubfolders(Level:=Range("F9").Value, ExtChoice:=Range("G9").Value, FileFilterOption:=Range("H9").Value, FileNameFilterStr:=Range("I9").Text)
    'Level                     : 1= Only the files in the folder, 2 to ? levels of subfolders
    'ExtChoice             :  0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
    'FileFilterOption     :  0=No Filter, 1=Begins, 2=Ends, 3=Contains
    'FileNameFilterStr   : Search string used when FileFilterOption = 1, 2 or 3


    'This code below will list all files on the first sheet of this workbook
    'In column A :B the path/name, C the file date/time and D the size
    'You can browse to the folder you want when the code Run

    'In this example we list the file names but you can also use MySplit(FileInMyFiles)
    'in the loop to for example to open the files with Workbooks.Open(MySplit(FileInMyFiles))

    If MyFiles <> "" Then
        With Application
            .ScreenUpdating = False
        End With

        'Delete all cells in columns A:C in the first worksheet of this workbook
        Sheets(1).Columns("A:D").Cells.Clear

        With Sheets(1).Range("A1:D1")
            .Value = Array("Directory", "File Name", "Date/Time", "Size")
            .Font.Bold = True
        End With

        'Split MyFiles and loop through all the files
        MySplit = Split(MyFiles, Chr(13))
        For FileInMyFiles = LBound(MySplit) To UBound(MySplit)
            On Error Resume Next
            Fstr = MySplit(FileInMyFiles)
            LastSep = InStrRev(Fstr, Application.PathSeparator, , 1)
            Sheets(1).Cells(FileInMyFiles   2, 1).Value = Left(Fstr, LastSep - 1)    'Column A
            Sheets(1).Cells(FileInMyFiles   2, 2).Value = Mid(Fstr, LastSep   1, Len(Fstr) - LastSep)    'Column B
            Sheets(1).Cells(FileInMyFiles   2, 3).Value = FileDateTime(MySplit(FileInMyFiles))    'Column C
            Sheets(1).Cells(FileInMyFiles   2, 4).Value = FileLen(MySplit(FileInMyFiles))    'Column D
            On Error GoTo 0
        Next FileInMyFiles
        Sheets(1).Columns("A:D").AutoFit
        With Application
            .ScreenUpdating = True
        End With
    Else
        MsgBox "Sorry no files that match your criteria, A 0 files result can be due to Apple sandboxing: Try using the Browse button to re-select the folder."
        'Delete all cells in columns A:D in the first worksheet of this workbook
        Sheets(1).Columns("A:D").Cells.Clear
        'ScreenUpdating is still True but we set it to true again to refresh the screen,
        With Application
            .ScreenUpdating = True
        End With
    End If

End Sub


'*******Function that do all the work that will be called by the macro*********

Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
                                              FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 4.0: 27 Sept 2015
'http://www.rondebruin.nl/mac.htm
'Thanks to DJ Bazzie Wazzie and Nigel Garvey(posters on MacScripter)
    Dim ScriptToRun As String
    Dim folderPath As String
    Dim FileNameFilter As String
    Dim Extensions As String

    On Error Resume Next
    folderPath = MacScript("choose folder as string")
    If folderPath = "" Then Exit Function
    On Error GoTo 0

    Select Case ExtChoice
    Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)"  'xls, xlsx , xlsm, xlsb
    Case 1: Extensions = "xls"    'Only  xls
    Case 2: Extensions = "xlsx"    'Only xlsx
    Case 3: Extensions = "xlsm"    'Only xlsm
    Case 4: Extensions = "xlsb"    'Only xlsb
    Case 5: Extensions = "csv"    'Only csv
    Case 6: Extensions = "txt"    'Only txt
    Case 7: Extensions = ".*"    'All files with extension, use *.* for everything
    Case 8: Extensions = "(xlsx|xlsm|xlsb)"  'xlsx, xlsm , xlsb
    Case 9: Extensions = "(csv|txt)"   'csv and txt files
        'You can add more filter options if you want,
    End Select

    Select Case FileFilterOption
    Case 0: FileNameFilter = "'.*/[^~][^/]*\." & Extensions & "$' "  'No Filter
    Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\." & Extensions & "$' "    'Begins with
    Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\." & Extensions & "$' "    ' Ends With
    Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\." & Extensions & "$' "   'Contains
    End Select

    folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
                           Chr(34) & " to return quoted form of it's POSIX Path")
    folderPath = Replace(folderPath, "'''", "'\''")

    If Val(Application.Version) < 15 Then
        ScriptToRun = ScriptToRun & "set foundPaths to paragraphs of (do shell script """ & "find -E " & _
                      folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
                      Level & """)" & Chr(13)
        ScriptToRun = ScriptToRun & "repeat with thisPath in foundPaths" & Chr(13)
        ScriptToRun = ScriptToRun & "set thisPath's contents to (POSIX file thisPath) as text" & Chr(13)
        ScriptToRun = ScriptToRun & "end repeat" & Chr(13)
        ScriptToRun = ScriptToRun & "set astid to AppleScript's text item delimiters" & Chr(13)
        ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to return" & Chr(13)
        ScriptToRun = ScriptToRun & "set foundPaths to foundPaths as text" & Chr(13)
        ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to astid" & Chr(13)
        ScriptToRun = ScriptToRun & "foundPaths"
    Else
        ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
                      folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
                      Level & """ "
    End If
    On Error Resume Next
    MyFiles = MacScript(ScriptToRun)
    On Error GoTo 0
End Function

Code2

Option Explicit

Sub MergeCode1()
    Dim BaseWks As Worksheet
    Dim rnum As Long
    Dim CalcMode As Long
    Dim MySplit As Variant
    Dim FileInMyFiles As Long
    Dim Mybook As Workbook
    Dim sourceRange As Range
    Dim destrange As Range
    Dim SourceRcount As Long

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    BaseWks.Range("A1").Font.Size = 36
    BaseWks.Range("A1").Value = "Please Wait"
    rnum = 3

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Clear MyFiles to be sure that it not return old info if no files are found
    MyFiles = ""

    'Get the files, set the level of folders and extension in the code line below
    Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
    'Level                       :  1= Only the files in the folder you select, 2 to ? levels of subfolders
    'ExtChoice               :  0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
    'FileFilterOption     :  0=No Filter, 1=Begins, 2=Ends, 3=Contains
    'FileNameFilterStr  : Search string used when FileFilterOption = 1, 2 or 3

    ' Work with the files if MyFiles is not empty.
    If MyFiles <> "" Then

        MySplit = Split(MyFiles, Chr(13))
        For FileInMyFiles = LBound(MySplit) To UBound(MySplit)

            Set Mybook = Nothing
            On Error Resume Next
            Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
            On Error GoTo 0

            If Not Mybook Is Nothing Then

                On Error Resume Next

                With Mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C5")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum   SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        Mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MySplit(FileInMyFiles)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum   SourceRcount
                    End If
                End If
                Mybook.Close savechanges:=False
            End If

        Next FileInMyFiles
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    BaseWks.Range("A1").Value = "Ready"
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Functions
    Option Explicit

    'Important: this Dim line must be at the top of your module
    Public MyFiles As String

    Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
                                                  FileFilterOption As Long, FileNameFilterStr As String)
    'Ron de Bruin,Version 4.0: 27 Sept 2015
    'http://www.rondebruin.nl/mac.htm
    'Thanks to DJ Bazzie Wazzie and Nigel Garvey(posters on MacScripter)
        Dim ScriptToRun As String
        Dim folderPath As String
        Dim FileNameFilter As String
        Dim Extensions As String

        On Error Resume Next
        folderPath = MacScript("choose folder as string")
        If folderPath = "" Then Exit Function
        On Error GoTo 0

        Select Case ExtChoice
        Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)"  'xls, xlsx , xlsm, xlsb
        Case 1: Extensions = "xls"    'Only  xls
        Case 2: Extensions = "xlsx"    'Only xlsx
        Case 3: Extensions = "xlsm"    'Only xlsm
        Case 4: Extensions = "xlsb"    'Only xlsb
        Case 5: Extensions = "csv"    'Only csv
        Case 6: Extensions = "txt"    'Only txt
        Case 7: Extensions = ".*"    'All files with extension, use *.* for everything
        Case 8: Extensions = "(xlsx|xlsm|xlsb)"  'xlsx, xlsm , xlsb
        Case 9: Extensions = "(csv|txt)"   'csv and txt files
            'You can add more filter options if you want,
        End Select

        Select Case FileFilterOption
        Case 0: FileNameFilter = "'.*/[^~][^/]*\." & Extensions & "$' "  'No Filter
        Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\." & Extensions & "$' "    'Begins with
        Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\." & Extensions & "$' "    ' Ends With
        Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\." & Extensions & "$' "   'Contains
        End Select

        folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
                               Chr(34) & " to return quoted form of it's POSIX Path")
        folderPath = Replace(folderPath, "'''", "'\''")

        If Val(Application.Version) < 15 Then
            ScriptToRun = ScriptToRun & "set foundPaths to paragraphs of (do shell script """ & "find -E " & _
                          folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
                          Level & """)" & Chr(13)
            ScriptToRun = ScriptToRun & "repeat with thisPath in foundPaths" & Chr(13)
            ScriptToRun = ScriptToRun & "set thisPath's contents to (POSIX file thisPath) as text" & Chr(13)
            ScriptToRun = ScriptToRun & "end repeat" & Chr(13)
            ScriptToRun = ScriptToRun & "set astid to AppleScript's text item delimiters" & Chr(13)
            ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to return" & Chr(13)
            ScriptToRun = ScriptToRun & "set foundPaths to foundPaths as text" & Chr(13)
            ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to astid" & Chr(13)
            ScriptToRun = ScriptToRun & "foundPaths"
        Else
            ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
                          folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
                          Level & """ "
        End If
        On Error Resume Next
        MyFiles = MacScript(ScriptToRun)
        On Error GoTo 0
    End Function

    Function RDB_Last(choice As Integer, rng As Range)
    'Ron de Bruin, 5 May 2008
    'Case 1 = last row
    'Case 2 = last column
    'Case 3 = last cell
        Dim lrw As Long
        Dim lcol As Integer

        Select Case choice

        Case 1:
            On Error Resume Next
            RDB_Last = rng.Find(What:="*", _
                                after:=rng.Cells(1), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Row
            On Error GoTo 0

        Case 2:
            On Error Resume Next
            RDB_Last = rng.Find(What:="*", _
                                after:=rng.Cells(1), _
                                Lookat:=xlPart, _
                                LookIn:=xlFormulas, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlPrevious, _
                                MatchCase:=False).Column
            On Error GoTo 0

        Case 3:
            On Error Resume Next
            lrw = rng.Find(What:="*", _
                           after:=rng.Cells(1), _
                           Lookat:=xlPart, _
                           LookIn:=xlFormulas, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, _
                           MatchCase:=False).Row
            On Error GoTo 0

            On Error Resume Next
            lcol = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
            On Error GoTo 0

            On Error Resume Next
            RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
            If Err.Number > 0 Then
                RDB_Last = rng.Cells(1).Address(False, False)
                Err.Clear
            End If
            On Error GoTo 0
        End Select
    End Function

How can we put it together?

Many thanks

Leave a Reply

Your email address will not be published. Required fields are marked *