VBA Экспорт Excel в CSV с диапазоном

Question

Я использовал код, который нашел здесь .

После некоторых изменений это код, который у меня сейчас есть:

Option Explicit
Sub ExportAsCSV()

Dim MyFileName As String
Dim Item As String
Dim Path As String
Dim CurrentWB As Workbook, TempWB As Workbook
Path = "F:\Excels\csv export\"

Set CurrentWB = ActiveWorkbook
ActiveWorkbook.Worksheets("Nieuw Artikelnummer").UsedRange.Copy
Item = Range("D2")

Set CurrentWB = ActiveWorkbook
ActiveWorkbook.Worksheets("csv").UsedRange.Copy

Set TempWB = Application.Workbooks.Add(1)
With TempWB.Sheets(1).Range("A1")
  .PasteSpecial xlPasteValues
  .PasteSpecial xlPasteFormats
End With

MyFileName = Path & "\" & Item & ".csv"

Application.DisplayAlerts = False
TempWB.SaveAs filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
MsgBox ".csv file has been created: " _
  & vbCrLf _
  & MyFileName
End Sub

У меня проблема в том, чтоон использует UsedRange, но я хотел бы выбрать диапазон, который копируется в новый файл .csv.

Что я могу сделать, чтобы выбрать диапазон для копирования в новый файл вместо UsedRange?

Answer 1

Откроется поле ввода на листе номера артикула, которое позволит вам вручную выбрать или ввести диапазон:

Sub ExportAsCSV()

Dim MyFileName As String
Dim Item As String
Dim Path As String
Dim CurrentWB As Workbook, TempWB As Workbook
Dim myrangeNA As Range
Dim myRangeCSV As Range
Path = "F:\Excels\csv export\"

Set CurrentWB = ActiveWorkbook
ActiveWorkbook.Worksheets("Nieuw Artikelnummer").Activate
Set myrangeNA = Application.InputBox(prompt:="Select a range to copy", Type:=8)
Item = Range("D2")

Set TempWB = Application.Workbooks.Add(1)
myrangeNA.Copy Destination:=TempWB.Worksheets("Sheet1").Range("A1")

MyFileName = Path & "\" & Item & ".csv"

Application.DisplayAlerts = False
TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True
TempWB.Close SaveChanges:=False
Application.DisplayAlerts = True
MsgBox ".csv file has been created: " _
  & vbCrLf _
  & MyFileName
End Sub

Если вы не хотите его выбирать, измените myrangeNAна любой диапазон, который вы хотите, например range("A5:C20"), и он должен работать.

Answer 2

Два других ваших вопроса в комментарии выше касаются вставки транспонированных значений, что вы бы сделали, изменив строку myrangeNA.Copy Destination:=TempWB.Worksheets("Sheet1").Range("A1") на

myrangeNA.Copy 
TempWB.Worksheets("Sheet1").Range("A1").PasteSpecial _ 
Paste:=xlPasteValues, Transpose:=True

Этот сайт является отличным справочным источником для всех различных объектов иметоды и свойства в коллекции Office VBA: https://docs.microsoft.com/en-us/office/vba/api/overview/excel/object-model (или https://docs.microsoft.com/de-de/office/vba/api/overview/excel/object-model, если вы предпочитаете переводить примерно пять слов на немецкий язык)

Answer 3

В подобных ситуациях я предпочитаю изолировать действия от автономных Sub или Function, которые я могу вызывать с параметрами.Таким образом, я могу использовать его по мере необходимости, либо в этом проекте, либо в другом.

Итак, я разделил действия: копирование выбранного диапазона данных и вставка во временную книгу, а затем сохранение в файл CSV.в своем собственном Function.Действие возвращает результат True / False в качестве проверки на успех.

Option Explicit

Sub test()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    Dim destCSVfile As String
    destCSVfile = "C:\Temp\" & ws.Range("D2")

    If ExportAsCSV(Selection, destCSVfile) Then
        MsgBox ".csv file has been created: " _
             & vbCrLf _
             & destCSVfile
    Else
        MsgBox ".csv file NOT created"
    End If
End Sub

Private Function ExportAsCSV(ByRef dataArea As Range, _
                             ByVal myFileName As String) As Boolean
    '--- make sure we have a range to export...
    ExportAsCSV = False
    If dataArea Is Nothing Then
        Exit Function
    End If

    dataArea.Copy

    '--- create a temporary workbook that will be saved as a CSV format
    Dim tempWB As Workbook
    Set tempWB = Application.Workbooks.Add(1)
    With tempWB.Sheets(1).Range("A1")
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With

    '--- suppress alerts to convert the temp book to CSV
    Application.DisplayAlerts = False
    tempWB.SaveAs filename:=myFileName, FileFormat:=xlCSV, _
                  CreateBackup:=False, Local:=True
    tempWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
    ExportAsCSV = True
End Function