Нужна помощь с макросом в Excel - Компьютерный форум OSzone.net

Компьютерный форум OSzone.net (http://forum.oszone.net/index.php)

- Microsoft Office (Word, Excel, Outlook и т.д.) (http://forum.oszone.net/forumdisplay.php?f=115)

- - Нужна помощь с макросом в Excel (http://forum.oszone.net/showthread.php?t=349564)

Нужна помощь с макросом в Excel

Доброго времени!

Просьба помочь с макросом в Excel.

Исходные данные:

Из программы контроля доступа в офис, выгружаю отчёт см. report4.xlsx, так же я там пометил, как хотелось бы чтобы макрос отрабатывал (зеленым) и как выгружается по умолчанию (черным).

Есть столбец "Name" в формате "Текст" вида "ИмяФамилияСотрудника" (в примере, заменил имена на цифры, не суть)
и столбец "Time" в формате "Текст" вида "2021-09-01 09:31:27"

Задача:

"Разбивать" каждого сотрудника по дням пустой строкой.

Код:

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 и отправлять на него таблицу с выгруженными данными.

ИМХО, удобнее использовать скрипт 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

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

Большое спасибо, 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

Цитата:

Цитата 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