Sub qqq()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Ëèñò1")
Dim rData As Range
Set rData = ws.ListObjects(1).DataBodyRange
Dim dStart As Date, dStop As Date, x As Long, house As Long
Dim dNew As Date, rw As Long: rw = 9
Dim iInt As Integer, iMod As Integer, i As Integer
With rData
ws.Range("E" & rw).CurrentRegion.ClearContents
For x = 1 To .Rows.Count
dStart = .Cells(x, 2)
dStop = .Cells(x, 3)
house = DateDiff("h", dStart, dStop)
If house > 24 Then
iInt = house / 24
iMod = house Mod 24
dNew = dStart
For i = 1 To IIf(iMod > 0, iInt + 1, iInt)
dNew = DateSerial(Year(dNew), Month(dNew), Day(dNew) + 1)
If dNew > dStop Then
dNew = DateSerial(Year(dStop), Month(dStop), Day(dStop))
ws.Range("B" & rw) = .Cells(x, 1)
ws.Range("C" & rw) = dNew
ws.Range("D" & rw) = dStop
ws.Range("C" & rw, ws.Range("D" & rw)).NumberFormat = "dd.mm.yyyy hh:mm"
ws.Range("E" & rw) = DateDiff("h", dNew, dStop)
Else
ws.Range("B" & rw) = .Cells(x, 1)
ws.Range("C" & rw) = dStart
ws.Range("D" & rw) = dNew
ws.Range("C" & rw, ws.Range("D" & rw)).NumberFormat = "dd.mm.yyyy hh:mm"
ws.Range("E" & rw) = DateDiff("h", dStart, dNew)
dStart = dNew
End If
rw = rw + 1
Next i
Else
ws.Range("B" & rw) = .Cells(x, 1)
ws.Range("C" & rw) = dStart
ws.Range("D" & rw) = dStop
ws.Range("C" & rw, ws.Range("D" & rw)).NumberFormat = "dd.mm.yyyy hh:mm"
ws.Range("E" & rw) = house
rw = rw + 1
End If
Next x
End With
End Sub
VBA. Аналог формулы ВПР(Excel) для работы с большими массивами., Способы реализации сопоставления данных в 2-х массивах с большим количеством "строк" (данных в 1-ой размерности).
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Dim iValue As String
iValue = Target.Value
Target = iValue & "."
Application.EnableEvents = True
End Sub
Sub Delete_Merge_Cells()
Dim target As Range
Set target = ActiveCell
If Intersect(target, Range("F:F")) Is Nothing Then Exit Sub
Dim wsDelete As Worksheet, rng As Range
Dim rw As Long
Set wsDelete = ThisWorkbook.Worksheets("Êîðçèíà")
If target.MergeCells Then
Set rng = target.MergeArea
With wsDelete
rw = .Range("D" & .Rows.Count).End(xlUp).Row + 1
rng.EntireRow.Copy .Range("A" & rw)
rng.EntireRow.Delete
End With
End If
End Sub
Если данные из CSV файла требуется для дальнейшей обработки, то можно их загнать в массив
Код
Sub Reading_CSV()
Dim FSO As Object, oFileText As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFileText = FSO.OpenTextFile("C:\Users\Harun\Documents\CSV file\Book2.csv", ForReading)
arr = oFileText.ReadAll
oFileText.Close
End Sub
В таком случае, лучше заносить данные в строку на лист "БазаОтчет" после заполнения протокола, а поля для ввода очищать для занесения следующих данных. Так как структура протокола не одинакова, может имеет смыл создать 4 базы данных (своя для каждого протокола). В случае необходимости восстановления протокола, возможет будет обратный порядок заполнения - из БД в протокол. Во вложении файл с макросом для примера работы из протокола в БД
Sub GetFilesCSV()
Dim FSO As Object, objFolder As Object
Dim wbOpen As Workbook, objFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = FSO.GetFolder("ВОТ СЮДА ПОЛНЫЙ ПУТЬ К ПАПКЕ")
For Each objFile In objFolder.Files
If UCase(objFile.Name) Like "*.CSV" Then
Set wbOpen = Workbooks.Open(objFile.Path)
Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wbOpen.Close False
End If
Next objFile
Set FSO = Nothing
End Sub
Sub GetFilesCSV()
Dim FSO As Object, objFolder As Object
Dim wbOpen As Workbook, objFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Выбрать папку"
.ButtonName = "Выбрать папку"
.Filters.Clear
.InitialFileName = "C:\Temp\"
.InitialView = msoFileDialogViewLargeIcons
If .Show = 0 Then Exit Sub
Set objFolder = FSO.GetFolder(.SelectedItems(1))
End With
For Each objFile In objFolder.Files
If UCase(objFile.Name) Like "*.CSV" Then
Set wbOpen = Workbooks.Open(objFile.Path)
Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wbOpen.Close False
End If
Next objFile
Set FSO = Nothing
End Sub
Sub qwert()
Dim arrMonth(), ws As Worksheet, lRow%
arrMonth = Array("январь", "февраль", "март", "апрель", "май", _
"июнь", "июль", "август", "сентябрь", "октябрь", "ноябрь", "декабрь")
Set ws = ThisWorkbook.ActiveSheet
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For x = 1 To lRow
If Not IsNumeric(Application.Match(.Range("A" & x).Value, arrMonth, 0)) Then
If x > 1 Then
.Range("A" & rw, .Range("B" & x)).Copy
.Range("D" & rw).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, True
End If
rw = x
col = 4
End If
If x = lRow Then
.Range("A" & rw, .Range("B" & x)).Copy
.Range("D" & rw).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone, False, True
End If
Next x
End With
End Sub
И вот такой вариант решения, если на одного ответственного приходится несколько городов и адресов. С одним адресом тоже работает
Код
Sub Podarki_NG()
Dim wsShablon As Worksheet, wsAdd As Worksheet, wsSheet As Worksheet
Dim arrData()
Dim dicWs As Object, dicCity As Object, dicAddress As Object, dicKont As Object
Dim x As Integer, i As Integer, rw As Integer, nub As Integer
Set dicWs = CreateObject("Scripting.Dictionary")
Set dicCity = CreateObject("Scripting.Dictionary")
Set dicAddress = CreateObject("Scripting.Dictionary")
Set dicKont = CreateObject("Scripting.Dictionary")
Set wsShablon = ThisWorkbook.Worksheets("ШАБЛОН")
Set wsSheet = ThisWorkbook.Worksheets("Лист рассылки")
nub = 2
Application.ScreenUpdating = False
With wsSheet
If .Range("A2") <> "" Then .Range("A2", .Range("E" & .Range("A2").End(xlDown).Row)).ClearContents
End With
If ThisWorkbook.Worksheets.Count > 4 Then
Application.DisplayAlerts = False
For x = ThisWorkbook.Worksheets.Count To 5 Step -1
ThisWorkbook.Worksheets(x).Delete
Next x
Application.DisplayAlerts = True
End If
arrData = ThisWorkbook.Sheets("Общий список").Range("A1").CurrentRegion.Value
For x = 2 To UBound(arrData, 1)
If Not dicWs.Exists(arrData(x, 10)) Then dicWs.Add arrData(x, 10), arrData(x, 10)
Next x
For x = 0 To dicWs.Count - 1
For i = 2 To UBound(arrData, 1)
If arrData(i, 10) = dicWs.Keys()(x) And Not dicCity.Exists(arrData(i, 8)) Then dicCity.Add arrData(i, 8), arrData(i, 8)
Next i
For i = 0 To dicCity.Count - 1
For r = 2 To UBound(arrData, 1)
If arrData(r, 10) = dicWs.Keys()(x) And arrData(r, 8) = dicCity.Keys()(i) Then
If Not dicAddress.Exists(arrData(r, 9)) Then
dicAddress.Add arrData(r, 9), arrData(r, 9)
If Not dicKont.Exists(arrData(r, 11)) Then dicKont.Add arrData(r, 11), arrData(r, 11)
End If
End If
Next r
For r = 0 To dicAddress.Count - 1
Set wsAdd = ThisWorkbook.Worksheets.Add(, ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
With wsAdd
.Name = dicWs.Keys()(x) & "-" & nub - 1
.Tab.Color = vbRed
wsShablon.Cells.Copy .Range("A1")
.Range("B4") = dicCity.Keys()(i)
.Range("B5") = dicAddress.Keys()(r)
.Range("B6") = dicWs.Keys()(x)
.Range("B7") = dicKont.Keys()(r)
rw = 10
For s = 2 To UBound(arrData, 1)
If arrData(s, 8) = dicCity.Keys()(i) And arrData(s, 9) = dicAddress.Keys()(r) And arrData(s, 10) = dicWs.Keys()(x) Then
.Range("E" & rw) = arrData(s, 2)
.Range("F" & rw) = arrData(s, 7)
rw = rw + 1
End If
Next s
.Range("B" & rw, .Range("B" & rw).End(xlDown)).EntireRow.Delete
End With
With wsSheet
.Range("A" & nub) = nub - 1
.Range("B" & nub) = dicCity.Keys()(i)
.Range("C" & nub) = dicAddress.Keys()(r)
.Range("D" & nub) = wsAdd.Range("C" & rw + 1)
.Range("E" & nub) = wsAdd.Name
nub = nub + 1
End With
Next r
dicAddress.RemoveAll
dicKont.RemoveAll
Next i
dicCity.RemoveAll
Next x
Set dicWs = Nothing
Set dicCity = Nothing
Set dicAddress = Nothing
Set dicKont = Nothing
Application.ScreenUpdating = True
End Sub
Sub www()
Dim FSO As Object, fFolders As Object, fFolder As Object
Dim sFolderName As String
Set FSO = CreateObject("Scripting.FileSystemObject")
sFolderName = "D:\Download"
Set fFolders = FSO.GetFolder(sFolderName)
For Each fFolder In fFolders.SubFolders
x = x + 1
Range("A" & x) = fFolder.Name
Next fFolder
End Sub
Sub qwe()
For x = 3 To Range("H" & Rows.Count).End(xlUp).Row
If Range("G" & x) = "" Then
Range("H" & x).ClearContents
Range("I" & x).ClearContents
For i = x + 1 To Range("H" & Rows.Count).End(xlUp).Row
If Range("G" & i) = "" Then
x = i - 1
Exit For
End If
Range("H" & x) = Range("H" & x) + Range("H" & i)
Range("I" & x) = Range("I" & x) + Range("I" & i)
Next i
End If
Next x
End Sub
Sub qwer()
Dim FSO As Object, oFile As Object
Dim wbOpen As Workbook, arr(), x As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
ReDim arr(1 To FSO.GetFolder(ThisWorkbook.Path & "\").Files.Count, 1 To 2)
For Each oFile In FSO.GetFolder(ThisWorkbook.Path & "\").Files
If oFile.Name <> ThisWorkbook.Name Then
x = x + 1
arr(x, 1) = oFile.Path
arr(x, 2) = Split(Split(FSO.GetFileName(oFile), "-КБ")(0), "П-")(1)
End If
Next oFile
With Range("A1").Resize(x, 2)
.Value = arr
Erase arr
.Sort Range("B1"), xlAscending
arr = .Value
.ClearContents
End With
For x = 1 To UBound(arr, 1)
Set wbOpen = Workbooks.Open(arr(x, 1))
'...
wbOpen.Close False
Next x
End Sub