VBA: Следующая пустая строка случайным образом перезаписывает некоторые строки - PullRequest
Новая
       10

VBA: Следующая пустая строка случайным образом перезаписывает некоторые строки

0 голосов
/ 12 июня 2018

У меня есть список файлов: Files

Они имеют один общий формат, имеют только один лист, но могут иметь несколько строк с данными.Они должны быть открыты, все ячейки с данными скопированы, а затем вставлены в лист с названием Адреса.Вот так:

WhatIWant

Однако я получаю следующее: WhatIHave

Теперь явмешались и заметили, что мои другие данные помещаются в пункт назначения, они просто перезаписываются (что выглядит случайным образом).Вот код, который я использовал: 

Option Explicit
Sub AddressListing()
  Dim Cell As Range
  With Worksheets("ghgh")
    For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Cells
      If Len(Dir(Cell.Value)) Then
        With Workbooks.Open(Cell.Value)
          Range("A2:X" & Cells(Rows.Count, "D").End(xlUp).Row).copy _
              ThisWorkbook.Worksheets("Addresses").Cells(Rows.Count, "A").End(xlUp).Offset(1)
          .Close SaveChanges:=False
        End With
      Else
        MsgBox "File not found: " & Cell.Value
      End If
    Next Cell
  End With
'Call RemoveViaFilter
End Sub

Чтобы бороться с этим и не тратить время каждого, я создал переменную NextRow, чтобы найти следующую пустую строку в книге.Это все еще не сработало.Я не получаю сообщение об ошибке, данные просто вводятся одинаково.Вот код с NextRow: 

Option Explicit
Sub AddressListing2()
  Dim Cell As Range
  Dim NextRow As Long
  NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
  With Worksheets("ghgh")
    For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Cells
      If Len(Dir(Cell.Value)) Then
        With Workbooks.Open(Cell.Value)
          Range("A2:X" & Cells(Rows.Count, "D").End(xlUp).Row).copy _
              ThisWorkbook.Worksheets("Addresses").Range("A" & NextRow)
          .Close SaveChanges:=False
        End With
      Else
        MsgBox "File not found: " & Cell.Value
      End If
    Next Cell
  End With
'Call RemoveViaFilter
End Sub

Я никогда не сталкивался с ошибками такого типа с NextRow.Я знаю, что «Найти следующую пустую строку и поместить туда данные» - это распространенный вопрос, поэтому я подумал, что NextRow решит эту проблему.Однако данные все еще перезаписываются, и я не сталкивался с какими-либо вопросами, которые касаются этого.

Я не хочу определенных диапазонов (например, A2: J100) и намеренно их избегаю потому что длина моих списков постоянно меняется.Это касается строк, которые я хочу вставить, и строк путей к файлам.

Любая помощь очень ценится, я уже несколько раз использовал «найти пустую строку» без проблем и не знаюпочему это перезаписывает данные.Это кажется противоположным всему процессу поиска пустой строки.

Ответы [ 2 ]

0 голосов
/ 12 июня 2018

Понятно, что NextRow рассчитывается неправильно.После вычисления введите код проверки: 

NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
While Application.WorksheetFunction.CountA(Rows(NextRow)) <> 0
    NextRow = NextRow + 1
Wend

Это обеспечит пустую строку NextRow.

0 голосов
/ 12 июня 2018

Это где вам поставить дополнительную строку ... 

   Option Explicit
    Sub AddressListing2()
      Dim Cell As Range
      Dim NextRow As Long
      NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
      With Worksheets("ghgh")
        For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Cells
          If Len(Dir(Cell.Value)) Then
            With Workbooks.Open(Cell.Value)
              Range("A2:X" & Cells(Rows.Count, "D").End(xlUp).Row).copy _
                  ThisWorkbook.Worksheets("Addresses").Range("A" & NextRow)
              .Close SaveChanges:=False
            End With
          Else
            MsgBox "File not found: " & Cell.Value
          End If
        'Add line here before going to new loop
        NextRow = ThisWorkbook.Sheets("Addresses").Range("D" & Rows.Count).End(xlUp).Row + 1
        Next Cell
      End With
    'Call RemoveViaFilter
    End Sub
...