时间戳

首页 > 解决方案 > VBA Excel 宏另存为脑筋急转弯

excel - VBA Excel 宏另存为脑筋急转弯

问题描述

我正在尝试输入文件名以保存带有更改选项的 Excel 工作表，除了从单元格中提取文件名并输入首选文件名代码外，一切正常

Public Sub EnterInfo()

Dim ROOM As String
Dim SiteName As String
Dim SiteID As String
Dim FSR As String

ROOM = InputBox("What is Room?", "Room Numner")
SiteName = InputBox("What is the Site Name?", "Site Name")
SiteID = InputBox("What is the Site ID?", "Site ID")
FSR = InputBox("What is your Name?", "Your Name")

Range("A3").Value = ROOM
Range("B3").Value = SiteName
Range("C3").Value = SiteID
Range("G3").Value = FSR
Range("D3").Value = Date

 Dim xWb As Workbook
    Dim xNewWb As Workbook
    Dim xFileName As String
    Dim xFolderPath As Variant
    Dim xDlg As FileDialog
    Set xWb = ActiveWorkbook

    
*'> FileName = "needed' A3+C3+D3... problem here, I need these cells to added to next section*


    xFileName = InputBox("Enter file name here, : ")
    If xFileName = "" Then Exit Sub
    Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
    If xDlg.Show = -1 Then
        xFolderPath = xDlg.SelectedItems(1)
        xWb.ActiveSheet.Range("b1:H41").Select
        Selection.Copy
        Set xNewWb = Workbooks.Add
        Range("b1:H41").PasteSpecial
        xNewWb.SaveAs xFolderPath & "\" & xFileName & ".xlsx"
        xNewWb.Close
    End If
End Sub

任何帮助，将不胜感激

标签： excelvba

解决方案

在这个想法中，最好的学习方法是通过获取好的示例，使用数组与变量重写您的脚本，并最小化与工作表的交互，而是将其移动到内存中。

    Option Explicit
    Option Base 1
    
    Public Sub EnterInfo()
        Dim i As Long, arr, topics, xFileName As String
        'instead of hardcoding vars we store the messages in an array
        topics = Array( _
            "What is Room?", _
            "What is the Site Name?", _
            "What is the Site ID?", _
            "What is your Name?" _
            )
        
        'with the values in an array we can now automate the iterations and write the responses and to all manipulations like get responses, setup the filename string, ...
        ReDim arr(1 To UBound(topics), 1 To 1)
        For i = 1 To UBound(topics)
            arr(i, 1) = InputBox(topics(i))
            xFileName = xFileName & CStr(arr(i, 1))
        Next i
        
        'all has been done in memory so we write to sheet
        With Sheet2
            .Range(.Cells(3, 1), .Cells(3, UBound(arr))).Value2 = arr
        End With
        
        'Get data for new workbook into an array
        Dim arr2
        arr2 = Sheet2.Range("B1:H41").Value2
            
        'save file in user selected folder
        Dim sFolder As String, xNewWb As Workbook
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = -1 Then ' if OK is pressed
                sFolder = .SelectedItems(1)
                Set xNewWb = Workbooks.Add
                With xNewWb.Sheets(1)
                    .Range(.Cells(1, 2), .Cells(41, 8)).Value2 = arr2
                End With
                xFileName = InputBox("Enter file name here, : ", , xFileName)
                xNewWb.SaveAs sFolder & "\" & xFileName & ".xlsx"
                xNewWb.Close
            End If
        End With
    End Sub

继续编码，如果您有任何其他问题，请不要犹豫。

推荐阅读