VBA-скрипт для экспорта листов в виде CSV-файлов в определенное место после удаления пустых или «пустых» строк, содержащих формулу - PullRequest
Новая
       21

VBA-скрипт для экспорта листов в виде CSV-файлов в определенное место после удаления пустых или «пустых» строк, содержащих формулу

0 голосов
/ 09 января 2019

Я работаю над сценарием VBA, чтобы разрешить манипулирование и экспорт ряда рабочих листов в виде файлов csv из рабочей книги Excel. Я хотел бы иметь возможность экспортировать список указанных листов в виде CSV-файлов в место сохранения, которое можно выбрать, кроме того, любая ячейка в определенном столбце, которая является пустой, но может содержать формулу, должна иметь всю строка удалена Приведенный ниже скрипт - это то, что у меня есть в данный момент, и кажется, что оно работает до определенного момента, но есть три основных вопроса:

  1. В строке ниже будут удалены строки, если ячейка в столбце A действительно пуста, т. Е. Не содержит формулу, но не работает при наличии формулы: Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

  2. Перемещение по листам неопрятно, но функционально, есть ли способ использовать список именованных листов, чтобы сделать скрипт более лаконичным?

  3. В идеале место сохранения также можно выбрать из диалогового окна выбора каталога файлов. Любые предложения о том, как этого добиться?

Большое спасибо заранее. 

Sub createCSVfiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Declare and set variables
Dim wb1 As Workbook, ws1 As Worksheet
Dim wbname As String, i As Integer
Set wb1 = ThisWorkbook

'Cycle through sheets
For i = 1 To Worksheets.Count
    wbname = Worksheets(i).Name

'Create Sheet1.csv
  If InStr(1, (Worksheets(i).Name), "Sheet1", vbTextCompare) > 0 Then
       Worksheets(i).Copy
       Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
       FileFormat:=xlCSV, CreateBackup:=False
       ActiveWorkbook.Close
      wb1.Activate
End If

'Create Sheet2.csv
If InStr(1, (Worksheets(i).Name), "Sheet2", vbTextCompare) > 0 Then
    Worksheets(i).Copy
    ActiveWorkbook.SaveAs Filename:="C:\Users\forename.surname\Desktop\export\" & ActiveSheet.Name & ".csv", _
    FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close
    wb.Activate
End If

Next i

'Clean
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

1 Ответ

0 голосов
/ 09 января 2019

Я думаю, что-то вроде того, что вы ищете: 

Sub createCSVfiles()

    'Declare and set variables
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim wsTemp As Worksheet
    Dim aSheets() As Variant
    Dim vSheet As Variant
    Dim sFilePath As String
    Dim sNewFileName As String
    Dim oShell As Object
    Dim i As Long

    'Select folder to save CSV files to
    Set oShell = CreateObject("Shell.Application")
    On Error Resume Next
    sFilePath = oShell.BrowseForFolder(0, "Select folder to save csv files", 0).Self.Path & Application.PathSeparator
    On Error GoTo 0
    If Len(sFilePath) = 0 Then Exit Sub 'Pressed cancel

    'Define sheet names here
    aSheets = Array("Sheet1", "Sheet2")

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Set wb = ThisWorkbook

    'Cycle through sheets
    For Each vSheet In aSheets
        'Test if sheet exists
        Set ws = Nothing
        On Error Resume Next
        Set ws = wb.Sheets(vSheet)
        On Error GoTo 0
        If Not ws Is Nothing Then
            'Sheet exists
            ws.Copy
            Set wsTemp = ActiveSheet

            'Remove rows with blanks in column A
            With wsTemp.Range("A1", wsTemp.Cells(wsTemp.Rows.Count, "A").End(xlUp))
                .AutoFilter 1, "=", xlFilterValues
                .Offset(1).EntireRow.Delete
                .AutoFilter
            End With

            'Save and close
            wsTemp.Parent.SaveAs sFilePath & wsTemp.Name & ".csv", xlCSV
            wsTemp.Parent.Close False
        End If
    Next vSheet

    'Clean
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub
...