Question

我想知道有没有办法解决这个code，以便我可以从工作簿导入和导出命名范围及其值，并通过.csv文件格式。

我可以成功导入或导出单个单元格的命名范围。但是在导出多单元命名范围时我得到错误，因为它们是数组。

将命名范围导出到csv的代码是

Option Explicit
Sub ExportCSV()
Dim ws As Worksheet
Dim str1 As String
Dim i As Long
Dim FinalRow As Long
Set ws = Sheets("Export")

With ws
Application.ScreenUpdating = False

ws.Activate


ws.Range("A1").Select
Selection.ListNames


 FinalRow = ws.Range("B9000").End(xlUp).Row
 For i = 1 To FinalRow
    Cells(i, "B") = Replace(Cells(i, "B"), "$", "")
 Next i

     Dim fileSaveName As Variant

     fileSaveName = Application.GetSaveAsFilename( _
                                        fileFilter:="Excel Files (*.csv), *.csv")
     If fileSaveName <> False Then
        'Code to save the file
      ws.Copy

       With ActiveWorkbook
       .SaveAs Filename:=fileSaveName, FileFormat:=xlCSV, CreateBackup:=False
       .Close False

       End With
     End If
ws.Cells.Clear

End With
Worksheets("Preferences").Activate
Range("A1").Select

Application.ScreenUpdating = True
MsgBox "Data Exported Successfully at " & vbNewLine & fileSaveName, vbInformation


End Sub

导入命名范围及其值的代码是

Option Explicit
Sub impdata()

    Dim MyCSV As Workbook
    Dim MyCSVPath As String
    Dim MyRange As Range
    Dim MyCell As Range
    Dim MyNextCell As Range
    Dim MyNamedRange As Range
    Dim ws As Worksheet
    Dim FinalRow As Long



    MyCSVPath = GetFile

    If MyCSVPath <> "" Then
        Set MyCSV = Workbooks.Open(MyCSVPath)
        Application.ScreenUpdating = False
        Set ws = Sheets(1)
        FinalRow = ws.Range("B90000").End(xlUp).Row
        Set MyRange = MyCSV.Worksheets(1).Range("B1" & ":B" & FinalRow)



        ThisWorkbook.Activate
        For Each MyCell In MyRange.Cells

            'Get a reference to the named range.
            Set MyNamedRange = Range(ThisWorkbook.Names(MyCell.Offset(, -1).Value))

            'Find the next empty cell in the named range.
            Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).End(xlUp).Offset(1)

            'If the next empty cell is above the named range, then set
            'it to the first cell in the range.
            If MyNextCell.Row < MyNamedRange.Cells(1).Row Then
                Set MyNextCell = MyNamedRange.Cells(1)
            End If

            'Place the value in the range.
            MyNextCell = MyCell.Value

        Next MyCell
    End If

    MyCSV.Close False
     Application.ScreenUpdating = True
End Sub

'---------------------------------------------------------------------------------------
' Procedure : GetFile
' Date      : 23/10/2015
' Purpose   : Returns the full file path of the selected file
' To Use    : vFile = GetFile()
'---------------------------------------------------------------------------------------
Function GetFile(Optional startFolder As Variant = -1) As Variant
    Dim fle As FileDialog
    Dim vItem As Variant
    Set fle = Application.FileDialog(msoFileDialogFilePicker)
    With fle
        .Title = "Select a File"
        .AllowMultiSelect = False
        .Filters.Add "Comma Separate Values", "*.CSV", 1
        If startFolder = -1 Then
            .InitialFileName = Application.DefaultFilePath
        Else
            If Right(startFolder, 1) <> "\" Then
                .InitialFileName = startFolder & "\"
            Else
                .InitialFileName = startFolder
            End If
        End If
        If .Show <> -1 Then GoTo NextCode
        vItem = .SelectedItems(1)
    End With
NextCode:
    GetFile = vItem
    Set fle = Nothing
End Function

Answer 1

导出代码

你已经放了With ws并且没有真正使用它代码，它会更安全，也更实用！ ;）

这是新的导出代码，如果只有一个单元格或文件名（放在文件夹“Save_as_CSV”中），它将保留一个列出命名范围的主文件，以便您可以找到它-import it）如果有多个单元格：

Option Explicit
Sub ExportCSV()
Dim Ws As Worksheet, _
    WsO As Worksheet, _
    Str1 As String, _
    i As Long, _
    ShName As String, _
    RgName As String, _
    FileName As String, _
    FileFullName As String, _
    RgO As Range, _
    FinalRow As Long, _
    FileSaveName As Variant

Application.ScreenUpdating = False
Set Ws = Sheets("Export")
Set WsO = Sheets("OutPut")

With Ws
    .Range("A1").ListNames
    FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
    For i = 1 To FinalRow
        If InStr(1, .Cells(i, "B"), ":") Then
            'NamedRange with Multiple cellS
            ShName = Replace(Replace(Split(.Cells(i, "B"), "!")(0), "=", ""), "'", "")
            RgName = Replace(Split(.Cells(i, "B"), "!")(1), "$", "")
            Set RgO = ThisWorkbook.Sheets(ShName).Range(RgName)
            WsO.Cells.Clear
            WsO.Range("A1").Resize(RgO.Rows.Count, RgO.Columns.Count).Value = RgO.Value
            FileName = .Cells(i, "A") & ".csv"
            FileFullName = ThisWorkbook.Path & "\Save_as_CSV\" & FileName
            'Code to save the file
            WsO.Copy
            With ActiveWorkbook
                .SaveAs FileName:=FileFullName, FileFormat:=xlCSV, CreateBackup:=False
                .Close False
            End With
            .Cells(i, "B") = FileName
        Else
            'NamedRange with only one cell
            .Cells(i, "B") = Replace(.Cells(i, "B"), "$", "")
        End If
    Next i

    FileSaveName = Application.GetSaveAsFilename(fileFilter:="Excel Files (*.csv), *.csv")
    If FileSaveName <> False Then
        'Code to save the file
        .Copy
        With ActiveWorkbook
            .SaveAs FileName:=FileSaveName, FileFormat:=xlCSV, CreateBackup:=False
            .Close False
        End With
    End If
    .Cells.Clear
End With

Worksheets("Preferences").Range("A1").Select
Application.ScreenUpdating = True
MsgBox "Data Exported Successfully at " & vbNewLine & FileSaveName, vbInformation
End Sub

导入代码

MyNextCell = MyCell.Value（我认为MyCell.Value是指定范围的地址）应该是：

MyNextCell.Resize(Range(MyCell.Value).Rows.Count, _
                    Range(MyCell.Value).Columns.Count).Value = _
       Sheets(Names(MyCell.Value).RefersToRange.Parent.Name).Range(MyCell.Value).Value

如果您使用CSV，这可能比Set MyCSV = Workbooks.Open(MyCSVPath, Local:=True)

Set MyCSV = Workbooks.Open(MyCSVPath)

如果您想将数据添加到您已有的数据中（之后我倾斜了，您必须只尝试更新它），Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).End(xlUp).Offset(1) （将从命名范围的末尾开始然后上升，然后偏移，因此它将为您提供指定范围的第二行）应该是：
```
Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).Offset(1)
```

如何以.csv格式导入/导出多单元命名范围

1 个答案:

导出代码

导入代码