365

megaloman · Отправлено: **00:43, 08-09-2021** | #2

Код:

Sub InBlanc()

    Set rID1 = Range("A4")         'Первая ячейка с Person Id
    Set rDT1 = Range("D4")         'Первая ячейка с Time

    PersonID = rID1
    DPerson = Mid(rDT1, 1, 10)
    
    j = rID1.Row + 1
    i = 1
    Do
        TPerson = rID1.Offset(i, 0)
        If Trim(TPerson) = "" Then Exit Do
        TDperson = Mid(rDT1.Offset(i, 0), 1, 10)
        
        If Not (PersonID = TPerson And DPerson = TDperson) Then
                Rows(CStr(j)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                i = i + 1
                j = j + 1
                PersonID = TPerson
                DPerson = TDperson
        End If
        i = i + 1
        j = j + 1
    Loop
    
End Sub

ИМХО, будет удобнее написать скрипт на VBS и отправлять на него таблицу с выгруженными данными.

megaloman · Отправлено: **08:00, 08-09-2021** | #3

ИМХО, удобнее использовать скрипт VBS

Код:

InXls = "D:\Мой контент\Загрузки\report4.xlsx"  'имя исходного Excel-файла

srID1 = "A4"                                    'Первая ячейка с Person Id
srDT1 = "D4"                                    'Первая ячейка с Time

With WScript.Arguments
    If .Count > 0 Then InXls = .Item(0)
End With

If Not CreateObject("Scripting.FileSystemObject").FileExists(InXls) Then
        MsgBox "Файл:" + vbCrLf + InXls + vbCrLf + "не найден"
        WScript.Quit 1
End If

With CreateObject("Excel.Application")
    .Visible = True  'True  ' False
    .Workbooks.Open InXls
    InBook = .ActiveWorkbook.Name
    InList = .Workbooks(InBook).ActiveSheet.Name

    PersonID = .Range(srID1)
    DPerson = Mid(.Range(srDT1), 1, 10)

    j = .Range(srID1).Row + 1
    i = 1

    Do
        TPerson = .Range(srID1).Offset(i, 0)
        If Trim(TPerson) = "" Then Exit Do
        TDperson = Mid(.Range(srDT1).Offset(i, 0), 1, 10)
        
        If Not (PersonID = TPerson And DPerson = TDperson) Then
            .Rows(CStr(j)).Insert -4121, 0
            i = i + 2
            j = j + 2
            PersonID = TPerson
            DPerson = TDperson
        Else
            i = i + 1
            j = j + 1
        End If
    Loop
End With

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

Brainiacs · Отправлено: **09:07, 08-09-2021** | #4

Большое спасибо, megaloman!!! (С меня пиво, можешь в личку присылать, куда отправлять)

Очень выручил макрос работает отлично, но у меня правда там ещё пару строк ('Delete columns from G to J и 'Replace name of cells, а дальше это твоё), когда будет время подскажешь как их в скрипт закинуть?!

Код:

Sub Macro1()
'
' Macro1 Macro
'

'Delete columns from G to J
Columns("G:J").Delete

'Replace name of cells
Cells.Replace What:="GlavniUlaz_Door1_Entrance Card Reader1", Replacement:= _
        "Entrance Card Reader1", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase _
        :=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:= _
        xlReplaceFormula2
        
Cells.Replace What:="GlavniUlaz_Door1_Exit Card Reader2", Replacement:= _
        "Exit Card Reader2", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase _
        :=False, SearchFormat:=False, ReplaceFormat:=False, FormulaVersion:= _
        xlReplaceFormula2


Set rID1 = Range("A4")         'First cell Person Id
    Set rDT1 = Range("D4")         'First cell Time

    PersonID = rID1
    DPerson = Mid(rDT1, 1, 10)
    
    j = rID1.Row + 1
    i = 1
    Do
        TPerson = rID1.Offset(i, 0)
        If Trim(TPerson) = "" Then Exit Do
        TDperson = Mid(rDT1.Offset(i, 0), 1, 10)
        
        If Not (PersonID = TPerson And DPerson = TDperson) Then
                Rows(CStr(j)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                i = i + 1
                j = j + 1
                PersonID = TPerson
                DPerson = TDperson
        End If
        i = i + 1
        j = j + 1
    Loop
'
End Sub

megaloman · Отправлено: **13:58, 08-09-2021** | #5

Цитата Brainiacs:

но у меня правда там ещё пару строк »

VBA Excel

В активной книге XLSM

Код:

Sub InBlanc()

    Set rID1 = Range("A4")                          'Первая ячейка с Person Id
    Set rDT1 = Range("D4")                          'Первая ячейка с Time

    MyDel = "G:J"                                   'Удаляемые столбцы
                                                    'Контекстное переименование
    MyRepl = Array("GlavniUlaz_Door1_Entrance Card Reader1", "Entrance Card Reader1", _
                   "GlavniUlaz_Door1_Exit Card Reader2", "Exit Card Reader2")

    Call Range(MyDel).Delete(-4159)
    For i = LBound(MyRepl) To UBound(MyRepl) Step 2
        Call Cells.Replace(MyRepl(i), MyRepl(i + 1), 2, 1)
    Next
    
    PersonID = rID1
    DPerson = Mid(rDT1, 1, 10)
    
    j = rID1.Row + 1
    i = 1
    Do
        TPerson = rID1.Offset(i, 0)
        If Trim(TPerson) = "" Then Exit Do
        TDperson = Mid(rDT1.Offset(i, 0), 1, 10)
        
        If Not (PersonID = TPerson And DPerson = TDperson) Then
            Rows(CStr(j)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            i = i + 2
            j = j + 2
            PersonID = TPerson
            DPerson = TDperson
        Else
            i = i + 1
            j = j + 1
        End If
    Loop
End Sub

Открываем другую книгу: XLSX, XLSM, XLS - из книги XLSM

Код:

InXls = "D:\Мой контент\Загрузки\report4.xlsx"  'имя исходного Excel-файла
srID1 = "A4"                                    'Первая ячейка с Person Id
srDT1 = "D4"                                    'Первая ячейка с Time

MyDel = "G:J"                                   'Удаляемые столбцы
                                                'Контекстное переименование
MyRepl = Array("GlavniUlaz_Door1_Entrance Card Reader1", "Entrance Card Reader1", _
               "GlavniUlaz_Door1_Exit Card Reader2", "Exit Card Reader2")

With CreateObject("Excel.Application")
    .Visible = True  'True  ' False
    .Workbooks.Open InXls

    Call .Range(MyDel).Delete(-4159)
    For i = LBound(MyRepl) To UBound(MyRepl) Step 2
        Call .Cells.Replace(MyRepl(i), MyRepl(i + 1), 2, 1)
    Next

    PersonID = .Range(srID1)
    DPerson = Mid(.Range(srDT1), 1, 10)

    j = .Range(srID1).Row + 1
    i = 1

    Do
        TPerson = .Range(srID1).Offset(i, 0)
        If Trim(TPerson) = "" Then Exit Do
        TDperson = Mid(.Range(srDT1).Offset(i, 0), 1, 10)
        
        If Not (PersonID = TPerson And DPerson = TDperson) Then
            .Rows(CStr(j)).Insert -4121, 0
            i = i + 2
            j = j + 2
            PersonID = TPerson
            DPerson = TDperson
        Else
            i = i + 1
            j = j + 1
        End If
    Loop
End With
End Sub

VBS

Код:

InXls = "D:\Мой контент\Загрузки\report4.xlsx"  'имя исходного Excel-файла
srID1 = "A4"                                    'Первая ячейка с Person Id
srDT1 = "D4"                                    'Первая ячейка с Time

MyDel = "G:J"                                   'Удаляемые столбцы
                                                'Контекстное переименование
MyRepl = Array("GlavniUlaz_Door1_Entrance Card Reader1", "Entrance Card Reader1", _
               "GlavniUlaz_Door1_Exit Card Reader2", "Exit Card Reader2")

With WScript.Arguments
    If .Count > 0 Then InXls = .Item(0)
End With

If Not CreateObject("Scripting.FileSystemObject").FileExists(InXls) Then
        MsgBox "Файл:" + vbCrLf + InXls + vbCrLf + "не найден"
        WScript.Quit 1
End If

With CreateObject("Excel.Application")
    .Visible = True  'True  ' False
    .Workbooks.Open InXls

    Call .Range(MyDel).Delete(-4159)
    For i = LBound(MyRepl) To UBound(MyRepl) Step 2
        Call .Cells.Replace(MyRepl(i), MyRepl(i + 1), 2, 1)
    Next

    PersonID = .Range(srID1)
    DPerson = Mid(.Range(srDT1), 1, 10)

    j = .Range(srID1).Row + 1
    i = 1

    Do
        TPerson = .Range(srID1).Offset(i, 0)
        If Trim(TPerson) = "" Then Exit Do
        TDperson = Mid(.Range(srDT1).Offset(i, 0), 1, 10)
        
        If Not (PersonID = TPerson And DPerson = TDperson) Then
            .Rows(CStr(j)).Insert -4121, 0
            i = i + 2
            j = j + 2
            PersonID = TPerson
            DPerson = TDperson
        Else
            i = i + 1
            j = j + 1
        End If
    Loop
End With