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

[Brainiacs]

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

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

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

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

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

Задача:

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

[megaloman]

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]

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]

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

но у меня правда там ещё пару строк »
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
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
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