Mac – Adapt existing VBA macro code to clear column, adjust row height and autofit column

macrosmicrosoft excelvbaworksheet-function

I am using Excel 2016

Previous question / thread is here

I have two worksheets "Data_Import" and "Pack".

Existing code imports folder names starting in the first blank cell of Column A.Then for every row that has new data it sets the row height to 18 and Column A to autofit,
This works perfectly.

I also need to clear all data in Column A of "Data_Import" and to start at Cell A1 and set the row heights to 18 and Column A to autofit.

Also do the same for worksheet "Pack" and for every row that has new data it sets the row height to 18 and Column A to autofit.

I am unable to get the "Pack" sheet for every row that has new data it sets the row height to 18 and Column A to autofit to work, the macro sets ALL rows to row height to 18 and it does not set AutoFit.

I would be grateful for any suggestions, many thanks.

Existing code from my other question

Sub GetFolderNames()
    Dim Answer As VbMsgBoxResult
    Dim xRow As Long
    Dim vSF As Object
    Dim xDirect$
    Dim InitialFoldr$
    Dim ws As Worksheet: Set ws = Sheets("Data_Import")
    Answer = MsgBox("Are you sure you want to run the macro - Import Folder Names", vbYesNo, "Run Import Folder Names Macro")
    If Answer = vbYes Then
        Application.ScreenUpdating = False
        xRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        InitialFoldr$ = "F:\" '<<< Startup folder to begin searching from
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = Application.DefaultFilePath & "\"
            .Title = "Please select a folder to list Files from"
            .InitialFileName = InitialFoldr$
            .Show
            If .SelectedItems.Count <> 0 Then
                xDirect$ = .SelectedItems(1) & "\"
            End If
        End With
        If xDirect$ <> "" Then
            With CreateObject("Scripting.FileSystemObject").GetFolder(xDirect$)
                For Each vSF In .subfolders
                    ws.Cells(xRow, 1) = Mid(vSF, InStrRev(vSF, "\") + 1)
                    xRow = xRow + 1
                Next vSF
            End With
            ws.Columns("A:A").AutoFit
        End If
    End If
End Sub

This is how I have tried to modify it so far

Sub ClearAllGetNewFolderNames()
     
    Dim xRow&, vSF
    Dim xDirect$, InitialFoldr$
    Dim Answer As VbMsgBoxResult
    Dim x As Integer
    Dim y As Integer
    Dim myRow As Integer

    Answer = MsgBox("Are You Sure You Want To Clear All Existing " & vbNewLine & "Data Records Before Importing New Data", vbYesNo, "Import Data")
    InitialFoldr$ = "F:\" '<<< Startup folder to begin searching from
    
    If Answer = vbYes Then
        Sheets("Data_Import").Select
        Columns("A:A").Select
        Selection.ClearContents
        Range("A1").Select
        Rows.RowHeight = 10
        
    End If
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show
        If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "\"
        End If
    End With
    
    If xDirect$ <> "" Then
        With CreateObject("Scripting.FileSystemObject").GetFolder(xDirect$)
            For Each vSF In .subfolders
                ActiveCell.Offset(xRow) = Mid(vSF, InStrRev(vSF, "\") + 1)
                xRow = xRow + 1
            Next vSF
        End With
        
    End If
    
        For x = 1 To ActiveSheet.UsedRange.Rows.Count
 
            ActiveSheet.UsedRange.Rows.RowHeight = 18
            Columns("A").EntireColumn.AutoFit
    Next x
        
        Sheets("Pack").Select
        
    For x = 1 To ActiveSheet.UsedRange.Rows.Count
        ActiveSheet.UsedRange.Rows.RowHeight = 18
        Columns("A:H").EntireColumn.AutoFit
    Next x

   
End Sub

Best Answer

Try this:

Sub GetFolderNames()
    Dim Answer As VbMsgBoxResult
    Dim xRow As Long
    Dim vSF As Object
    Dim xDirect$
    Dim InitialFoldr$
    Dim ws As Worksheet: Set ws = Sheets("Data_Import")
    Dim ws2 As Worksheet: Set ws2 = Sheets("Path")
    Answer = MsgBox("Are you sure you want to run the macro - Import Folder Names", vbYesNo, "Run Import Folder Names Macro")
    If Answer = vbYes Then
        Application.ScreenUpdating = False

        ws.Range("A1").CurrentRegion.ClearContents
        xRow = 1

        InitialFoldr$ = "F:\" '<<< Startup folder to begin searching from
        With Application.FileDialog(msoFileDialogFolderPicker)
            .InitialFileName = Application.DefaultFilePath & "\"
            .Title = "Please select a folder to list Files from"
            .InitialFileName = InitialFoldr$
            .Show
            If .SelectedItems.Count <> 0 Then
                xDirect$ = .SelectedItems(1) & "\"
            End If
        End With
        If xDirect$ <> "" Then
            With CreateObject("Scripting.FileSystemObject").GetFolder(xDirect$)
                For Each vSF In .subfolders
                    ws.Cells(xRow, 1) = Mid(vSF, InStrRev(vSF, "\") + 1)
                    xRow = xRow + 1
                Next vSF
            End With
            
            ws.Columns("A:A").AutoFit
            ws2.Columns("A:A").AutoFit
            ws.Range("A1:A" & xRow - 1).RowHeight = 18
            ws2.Range("A1:A" & xRow - 1).RowHeight = 18
            
        End If
    End If
End Sub

I am going to edit your question to be a little more concise.

Hope this helps. Justin

Related Question