VBA копирует данные, игнорируя "" и заголовок, если данных не существует

Question

Я работал над кодом, который должен копировать информацию из входных файлов в мастер-файл.Все работало хорошо, пока я не проверил файлы без данных.Вот проблема: Входной файл имеет 3 раздела, которые пользователь может заполнить (расходы, пробег и пособие).Каждый из этих входных данных собирается в отдельном листе импорта, чтобы подготовить данные для импорта в дальнейшем.Когда я «собираю» данные в свои собственные таблицы, я использую формулы с iferror -> «», что означает, что строки могут не отображать значения, но Excel считает, что это так.Следующим шагом является копирование соответствующих данных с каждого из листов импорта на главный лист.Я хочу всегда игнорировать заголовок, и я хочу только фактические данные, а не "".Я погуглил формулу, которая решает эту «проблему» для поиска последней «использованной строки», и был очень доволен :).Однако, если лист импорта пуст, т.е. не заполнена ни одна строка, кроме заголовка, магия перестает работать. И шансы, что пользователь только заполняет, скажем, просто расходы, очень высоки.

Любой изу светлых умов есть идея, как мне решить проблему?Я очень ценю это!

Sub SPOTImport() 'SPOT import

   Dim Fname As Variant
   Dim SrcWbk As Workbook
   Dim DestWbk As Workbook
   Dim LastRow1 As Variant
   Dim LastRow2 As Variant
   Dim LastRow3 As Variant
   Dim LastRowHere As Variant
   Dim i As Integer
   Dim wbExport As Workbook
    Dim wsToExport As Worksheet
    Dim xPath As String
    xPath = Application.ActiveWorkbook.Path

    Set DestWbk = ThisWorkbook
    'delete all data but header to begin the preparation
LastRowHere = DestWbk.Sheets("Import").Cells(Rows.Count, 1).End(xlUp).Row
DestWbk.Sheets("Import").Range("A2:I" & LastRowHere).Delete

   'choose files and define them as array
   Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Välj alla filer som lämnades in", MultiSelect:=True)
   If IsArray(Fname) Then
   'Define array start and finish
   For i = LBound(Fname) To UBound(Fname)

   'define workbook name based on each value in array
   Set SrcWbk = Workbooks.Open(Fname(i))

   'define lastrow for each sheeet that also ignores the "" in formulas
   LastRow1 = SrcWbk.Sheets("Import_EXPENSE").Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row
   LastRow2 = SrcWbk.Sheets("Import_TRAVEL").Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row
   LastRow3 = SrcWbk.Sheets("Import_ALLOWENCE").Columns("A").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row

      'copy data from each sheet to destnation file
     SrcWbk.Sheets("Import_EXPENSE").Range("A2:I" & LastRow1).Copy
    With DestWbk.Worksheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .PasteSpecial Paste:=xlPasteValues
    End With

      SrcWbk.Sheets("Import_TRAVEL").Range("A2:I" & LastRow2).Copy
    With DestWbk.Worksheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .PasteSpecial Paste:=xlPasteValues
    End With

     SrcWbk.Sheets("Import_ALLOWENCE").Range("A2:I21" & LastRow3).Copy
    With DestWbk.Worksheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    .PasteSpecial Paste:=xlPasteValues
    End With

Application.DisplayAlerts = False
SrcWbk.Close False
Application.DisplayAlerts = True

   Next i
   End If

'export sheet as csv
Set wsToExport = ThisWorkbook.Worksheets("Import")     'Sheet to export as CSV
Set wbExport = Application.Workbooks.Add
wsToExport.Copy Before:=wbExport.Worksheets(wbExport.Worksheets.Count)
Application.DisplayAlerts = False                       'Possibly overwrite without asking
wbExport.SaveAs Filename:=xPath & "\" & "SPOT Import" & " " & Format(Date, "yyyymmdd"), FileFormat:=xlCSV
Application.DisplayAlerts = True
wbExport.Close SaveChanges:=False


'select sheet
ThisWorkbook.Sheets("Import").Select

'magic ready
MsgBox "SPOT Import csv fil är klar!"

End Sub 

Answer 1

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

  If LastRow1 > 1 Then
            If WorksheetFunction.CountIf(SrcWbk.Sheets("Import_EXPENSE").Columns(1), "<>") > 1 Then 'Filter for the data
            SrcWbk.Sheets("Import_EXPENSE").UsedRange.AutoFilter 1, "<>" 'Copy the filtered data
            SrcWbk.Sheets("Import_EXPENSE").Range("A2:I" & LastRow1).Copy 'Paste the data
            With DestWbk.Worksheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            .PasteSpecial Paste:=xlPasteValues
            End With
            End If
      End If

Answer 2

Примените фильтр к исходному листу для «Значение не пустое» (например, critieria:="<>"), чтобы отфильтровать пустые строки, и используйте WorksheetFunction.CountIf, чтобы проверить, есть ли любые непустыестрок на листе перед копированием.

На основании вашего кода:

'Is there more data than just the Header Row in Column A?
If WorksheetFunction.CountIf(SrcWbk.Sheets("Import_EXPENSE").Columns(1),"<>") > 1 Then
    'Filter for the data
    SrcWbk.Sheets("Import_EXPENSE").UsedRange.AutoFilter 1, "<>"
    'Copy the filtered data
    SrcWbk.Sheets("Import_EXPENSE").Range("A2:I" & LastRow1).Copy
    'Paste the data
    With DestWbk.Worksheets("Import").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        .PasteSpecial Paste:=xlPasteValues
    End With
End If

другие незначительные оптимизации, которые можно выполнить: например, этокод может быть уменьшен в 2 этапа:

'Long form, unoptimised
Range1.Copy
With Range2
    .PasteSpecial Paste:=xlPasteValues
End With

'Remove the With
Range1.Copy
Range2.PasteSpecial Paste:=xlPasteValues

'Direct copy, without using Clipboard
Range1.Copy Destination:=Range2