调整现有的 VBA 宏代码以清除列、调整行高和自动调整列

Question

我正在使用 Excel 2016

上一个问题/主题在此处

我有两个工作表“Data_Import”和“Pack”。

现有代码从 A 列的第一个空白单元格开始导入文件夹名称。然后对于每一行包含新数据的内容，它将行高设置为 18，并将 A 列设置为自动调整，这样效果很好。

我还需要清除“Data_Import”的 A 列中的所有数据，并从单元格 A1 开始，将行高设置为 18，将 A 列设置为自动调整。

对工作表“Pack”执行相同操作，对于具有新数据的每一行，它将行高设置为 18，并将 A 列设置为自动调整。

我无法让“Pack”表中的每一行都有新数据，它将行高设置为 18，并将 A 列设置为自动调整，宏将所有行的行高设置为 18，并且不设置自动调整。

如有任何建议，我将不胜感激，非常感谢。

我的另一个问题的现有代码

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

这是我迄今为止尝试修改的方法

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

Answer 1

尝试这个：

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

我将编辑您的问题，使其更简洁一些。

希望这能有所帮助。贾斯汀