Страницы: Пред. 1 2
RSS
Сводный отчёт из нескольких файлов
 
Тогда эти две процедуры надо заменить:
Код
Sub Job_sum_sheet1(shSum As Worksheet)
    With shSum
        Dim y As Long
        With .UsedRange
            y = .Row + .Rows.Count
        End With
        If y < 2 Then y = 2
        .Rows("2:" & y).Delete Shift:=xlUp
    End With
End Sub
Код
Sub DeleteEmptyRow(sh As Worksheet)
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        Dim e As Variant
        If y = 1 Then y = 2
        
        a = .Range(.Cells(1, 1), .Cells(y, 1))
        e = .Range(.Cells(1, 5), .Cells(y, 5))
        
        For y = UBound(a, 1) To 2 Step -1
            If a(y, 1) = "" Or e(y, 1) <> "+" Then
                .Rows(y).Delete
            End If
        Next
    End With
End Sub
 
МатросНаЗебре, баг с затиранием  первой строчки исчез, но строка №8 из исходников в итоговый отчёт  не попадает.

Результат работы макроса приложил.
 
МатросНаЗебре, некорректно отрабатывает последняя процедура удаления пустых строк
Код
Sub DeleteEmptyRow(sh As Worksheet)
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        Dim e As Variant
        If y = 1 Then y = 2
         
        a = .Range(.Cells(1, 1), .Cells(y, 1))
        e = .Range(.Cells(1, 5), .Cells(y, 5))
         
        For y = UBound(a, 1) To 2 Step -1
            If a(y, 1) = "" Or e(y, 1) <> "+" Then
                .Rows(y).Delete
            End If
        Next
    End With
End Sub
Изменено: Владимир Никифоров - 30.12.2019 14:24:02
 
8 строка пропадала, так как определялась как пустая. Тогда так:
Код
Sub DeleteEmptyRow(sh As Worksheet)
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        Dim e As Variant
        If y = 1 Then y = 2
        
        a = .Range(.Cells(1, 1), .Cells(y, 1))
        e = .Range(.Cells(1, 5), .Cells(y, 5))
        
        For y = UBound(a, 1) To 2 Step -1
            If e(y, 1) = "+" Then
            ElseIf a(y, 1) = "" Then
                .Rows(y).Delete
            End If
        Next
    End With
End Sub
 
МатросНаЗебре, теперь остальные пустые строки не удаляются, а только скрываются.

[CODE][/CODE]
Изменено: Владимир Никифоров - 30.12.2019 14:48:27
 
Код
Sub DeleteEmptyRow(sh As Worksheet)
    With sh
        Dim y As Long
        y = .Cells(.Rows.Count, 1).End(xlUp).Row
        Dim a As Variant
        Dim e As Variant
        If y = 1 Then y = 2
        
        a = .Range(.Cells(1, 1), .Cells(y, 1))
        e = .Range(.Cells(1, 5), .Cells(y, 5))
        
        For y = UBound(a, 1) To 2 Step -1
            If e(y, 1) <> "+" Then
                .Rows(y).Delete
            End If
        Next
    End With
End Sub
 
МатросНаЗебре, УРА! Макрос работает, единственное, что логика сортировки файлов у Windows и VBA немного разная, поэтому в итоговом отчёте порядок файлов логичный, но отличается от от Windows. Но это уже мелочи, главное удалось победить ручной перебор и редактирование. Благодарю Вас от всей души, за то что терпеливо возились с этим макросом. Также благодарю всех, кто помог советом, ссылкой и др. Поздравляю всех форумчан с наступающими праздниками и желаю всех благ. :)  
 
.
Изменено: Vlad_Sm - 10.11.2020 10:06:27
Страницы: Пред. 1 2
Наверх