Загрузка данных


Private Sub ОформитьЛисты(ByVal wsSummary As Worksheet, ByVal wsRepairs As Worksheet, ByVal wsReasons As Worksheet, ByVal wsFiles As Worksheet, ByVal wsDash As Worksheet, ByVal wsDESNP As Worksheet, ByVal wsBoilNP As Worksheet)
    ОформитьОдинЛист wsSummary
    ОформитьОдинЛист wsRepairs
    ОформитьОдинЛист wsReasons
    ОформитьОдинЛист wsFiles
    ОформитьОдинЛист wsDESNP
    ОформитьОдинЛист wsBoilNP

    wsSummary.Columns("A").NumberFormat = "dd.mm.yyyy"
    wsRepairs.Columns("A").NumberFormat = "dd.mm.yyyy"
    wsFiles.Columns("B").NumberFormat = "dd.mm.yyyy"
    wsDESNP.Columns("A").NumberFormat = "dd.mm.yyyy"
    wsBoilNP.Columns("A").NumberFormat = "dd.mm.yyyy"

    wsDash.Columns("A:F").ColumnWidth = 16
    wsDash.Columns("J:O").EntireColumn.AutoFit
    wsDash.Range("A3:E7").Font.Bold = True
End Sub

Private Sub ОформитьОдинЛист(ByVal ws As Worksheet)
    With ws.Rows(1)
        .Font.Bold = True
        .Interior.Color = RGB(217, 225, 242)
    End With
    ws.Cells.EntireColumn.AutoFit
    On Error Resume Next
    ws.Rows(1).AutoFilter
    On Error GoTo 0
End Sub

Private Function ПолучитьИлиСоздатьЛист(ByVal sheetName As String) As Worksheet
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets
        If LCase$(ws.Name) = LCase$(sheetName) Then
            Set ПолучитьИлиСоздатьЛист = ws
            Exit Function
        End If
    Next ws

    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    ws.Name = Left$(sheetName, 31)
    Set ПолучитьИлиСоздатьЛист = ws
End Function

Private Function ИзвлечьДатуИзИмениФайла(ByVal fileName As String) As Variant
    Dim re As Object, m As Object
    Dim d As Integer, mn As Integer, y As Integer

    Set re = CreateObject("VBScript.RegExp")
    re.Global = False
    re.IgnoreCase = True
    re.Pattern = "(\d{1,2})[.\-_](\d{1,2})[.\-_](\d{4})"

    If re.Test(fileName) Then
        Set m = re.Execute(fileName)(0)
        d = CInt(m.SubMatches(0))
        mn = CInt(m.SubMatches(1))
        y = CInt(m.SubMatches(2))
        ИзвлечьДатуИзИмениФайла = DateSerial(y, mn, d)
    Else
        ИзвлечьДатуИзИмениФайла = Empty
    End If
End Function

Private Function ПоследняяСтрока(ByVal ws As Worksheet) As Long
    Dim f As Range

    On Error Resume Next
    Set f = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0

    If f Is Nothing Then
        ПоследняяСтрока = 1
    Else
        ПоследняяСтрока = f.Row
    End If
End Function

Private Function ЧислоИзЯчейки(ByVal v As Variant) As Double
    Dim s As String

    If IsNumeric(v) Then
        ЧислоИзЯчейки = CDbl(v)
        Exit Function
    End If

    s = Trim$(CStr(v))
    If s = "" Or s = "-" Then Exit Function

    s = Replace(s, Chr(160), "")
    s = Replace(s, " ", "")
    s = Replace(s, "кВт", "", , , vbTextCompare)
    s = Replace(s, "квт", "", , , vbTextCompare)
    s = Replace(s, "л.", "", , , vbTextCompare)
    s = Replace(s, "л", "", , , vbTextCompare)
    s = Replace(s, "м³", "", , , vbTextCompare)
    s = Replace(s, "м3", "", , , vbTextCompare)
    s = Replace(s, ",", ".")

    If IsNumeric(s) Then
        ЧислоИзЯчейки = CDbl(s)
    End If
End Function

Private Function ТекстСтроки(ByVal ws As Worksheet, ByVal r As Long) As String
    Dim lastCol As Long, c As Long, s As String, v As String

    lastCol = ws.Cells(r, ws.Columns.Count).End(xlToLeft).Column
    For c = 1 To lastCol
        v = Trim$(CStr(ws.Cells(r, c).Text))
        If v <> "" Then s = s & " " & v
    Next c

    ТекстСтроки = Trim$(s)
End Function

Private Sub ЗаписатьФайл(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal fileName As String, ByVal dt As Variant, ByVal statusText As String, ByVal commentText As String)
    ws.Cells(rowNum, 1).Value = fileName
    If IsDate(dt) Then ws.Cells(rowNum, 2).Value = CDate(dt)
    ws.Cells(rowNum, 3).Value = statusText
    ws.Cells(rowNum, 4).Value = commentText
End Sub

Private Sub ОчиститьСерии(ByVal ch As Chart)
    On Error Resume Next
    Do While ch.SeriesCollection.Count > 0
        ch.SeriesCollection(1).Delete
    Loop
    On Error GoTo 0
End Sub

Private Sub УдалитьВсеДиаграммы(ByVal ws As Worksheet)
    Dim i As Long
    For i = ws.ChartObjects.Count To 1 Step -1
        ws.ChartObjects(i).Delete
    Next i
End Sub

Private Sub ОтсортироватьДаты(ByRef arr As Variant)
    Dim i As Long, j As Long, tmp As Variant

    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If CDate(arr(j)) < CDate(arr(i)) Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
            End If
        Next j
    Next i
End Sub

Private Sub ОтсортироватьСтроки(ByRef arr As Variant)
    Dim i As Long, j As Long, tmp As Variant

    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If CStr(arr(j)) < CStr(arr(i)) Then
                tmp = arr(i)
                arr(i) = arr(j)
                arr(j) = tmp
            End If
        Next j
    Next i
End Sub