Option Explicit
Sub Перенести()
Dim rSource As Range
Set rSource = GetSourceRange()
If rSource Is Nothing Then Exit Sub
Dim shTarget As Worksheet
Set shTarget = GetTargetSheet()
If shTarget Is Nothing Then Exit Sub
CopyData rSource, shTarget
End Sub
Private Sub CopyData(rSource As Range, shTarget As Worksheet)
Dim aSource As Variant
aSource = rSource.FormulaR1C1
Dim aTarget As Variant
aTarget = shTarget.UsedRange.Resize(shTarget.UsedRange.Rows.Count + UBound(aSource, 1)).Value
Dim nomerSource As Variant, dateSource As Variant
GetSourceData rSource.Parent, nomerSource, dateSource
Dim ys As Long, yt As Long, vv As Variant, yxx As Variant, yf As Long, xf As Long, xt As Long, updated As Boolean, newYmin As Long, newYmax As Long
For ys = 1 To UBound(aSource, 1)
If IsNumeric(aSource(ys, 1)) Then
For yt = 1 To UBound(aTarget, 1)
If aTarget(yt, 1) = dateSource Then
If aTarget(yt, 3) = nomerSource Then
If aTarget(yt, 9) = aSource(ys + 1, 2) Then
If aTarget(yt, 26) = aSource(ys + 1, 9) Then
Exit For
End If
End If
End If
End If
Next
If yt = UBound(aTarget, 1) + 1 Then
For yt = UBound(aTarget, 1) To 1 Step -1
If Not IsEmpty(aTarget(yt, 9)) Then Exit For
Next
yt = yt + 1
If newYmin = 0 Then newYmin = yt
newYmax = yt
aTarget(yt, 1) = dateSource
aTarget(yt, 3) = nomerSource
End If
For Each vv In Split("1 1 5;1 2 10;1 4 15;1 6 13;1 9 27;1 11 32;1 13 30;2 2 9;2 4 16;2 9 26;2 11 33", ";")
yxx = Split(vv, " ")
yf = yxx(0)
xf = yxx(1)
xt = yxx(2)
If Not IsEmpty(aSource(ys + yf - 1, xf)) Then
If CStr(aTarget(yt, xt)) <> CStr(aSource(ys + yf - 1, xf)) Then
aTarget(yt, xt) = aSource(ys + yf - 1, xf)
updated = True
End If
End If
Next
End If
Next
If updated Then
With shTarget.UsedRange.Resize(UBound(aTarget, 1), UBound(aTarget, 2))
If newYmin > 4 Then
.Rows(4).Copy .Rows(newYmin & ":" & newYmax)
.Rows(newYmin & ":" & newYmax).ClearContents
End If
.FormulaR1C1 = aTarget
End With
End If
End Sub
Private Function GetTargetSheet() As Worksheet
Dim wb As Workbook, sh As Worksheet
For Each wb In Workbooks
For Each sh In wb.Worksheets
If sh.Range("A2").Value = "Дата" Then
Set GetTargetSheet = sh
Exit Function
End If
Next
Next
Workbooks.Add (1)
ActiveSheet.Range("A2").Value = "Дата"
Set GetTargetSheet = ActiveSheet
End Function
Private Function GetSourceRange() As Range
Dim wb As Workbook, sh As Worksheet, rr As Range
For Each wb In Workbooks
For Each sh In wb.Worksheets
On Error Resume Next
Set rr = sh.Cells.Find("ИСТОЧНИК", LookAt:=xlWhole)
Set rr = rr.Resize(sh.UsedRange.Rows.Count).Find("№", LookAt:=xlWhole)
Set rr = rr.Resize(sh.UsedRange.Rows.Count).Find(1, LookAt:=xlWhole)
On Error GoTo 0
If Not rr Is Nothing Then
Set GetSourceRange = rr.Cells(2, 1).Resize(sh.UsedRange.Rows.Count, sh.UsedRange.Columns.Count)
Set rr = Nothing
End If
If Not GetSourceRange Is Nothing Then Exit Function
Next
Next
End Function
Private Sub GetSourceData(sh As Worksheet, nomerSource As Variant, dateSource As Variant)
Dim rr As Range
On Error Resume Next
Set rr = sh.UsedRange.Find("Перемещение бюджетных средств №*от*", LookAt:=xlWhole)
On Error GoTo 0
If rr Is Nothing Then Exit Sub
Dim ss As String
ss = rr.Value
ss = Replace(ss, "Перемещение бюджетных средств №", "")
ss = Replace(ss, " г.", "")
Dim arr As Variant
arr = Split(ss, " от ")
If UBound(arr) > 0 Then
nomerSource = arr(0)
dateSource = arr(1)
If IsNumeric(nomerSource) Then nomerSource = CLng(nomerSource)
If IsDate(dateSource) Then dateSource = CDate(dateSource)
Else
nomerSource = ss
End If
End Sub
|
