lmb1.bas

lmb--路面工程数量计算软件

'增加表格框
    Dim ys As Integer, hs As Integer, zhs As Integer, ys1 As Integer, ys2 As Single
        zhs = tt + hang
        ys2 = (zhs - 6) / 24
        ys1 = Fix(ys2)
        If ys2 - ys1 > 0 Then
            ys = ys1 + 1
        Else
            ys = ys1
        End If
        hs = (ys - 1) * 24 + 30
    xlsheet5.Activate
    If yljk = 0 Then
    xlsheet5.Range(xlsheet5.Cells(7, 1), xlsheet5.Cells(hs, "R")).Select
    Else
    xlsheet5.Range(xlsheet5.Cells(7, 1), xlsheet5.Cells(hs, "Z")).Select
    End If
    xlbook.Application.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    xlbook.Application.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With xlbook.Application.Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlbook.Application.Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlbook.Application.Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlbook.Application.Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlbook.Application.Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With xlbook.Application.Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    xlsheet5.Range("A1").Select
End Sub
Function gbzh(zh As Double) As String
    Dim k1 As Single
    Dim k3 As String
    Dim k4 As String
    Dim k2 As Single
    k1 = Int(zh / 1000)
    k2 = zh - k1 * 1000
    k3 = CStr(k1)
    k4 = CStr(k2)
    If k2 = 0 Then
        k4 = "000"
    ElseIf (10 > k2) And (k2 > 0) Then
        k4 = "00" & k4
    ElseIf (100 > k2) And (k2 > 10) Then
        k4 = "0" & k4
    End If
    gbzh = "K" & k3 & "+" & k4
End Function
'找出不同的字符串
Function member1(str() As String, str0 As String) As Integer
    If member0(str, str0) = 0 And str0 <> "" Then
        ReDim Preserve str(UBound(str) + 1)
        str(UBound(str)) = str0
        member1 = 1
    Else
        member1 = 0
    End If
End Function
Function member0(str() As String, str0 As String) As Integer
    Dim i As Integer
    member0 = 0
    For i = 1 To UBound(str)
        If str0 = str(i) Then
            member0 = i
            Exit Function
        End If
    Next i
End Function
Sub tqs(str1() As String, str() As String)
    Dim i As Integer, j As Integer
    ReDim str1(0) As String
    For i = 1 To UBound(str, 1)
        For j = 1 To UBound(str, 2)
            Call member1(str1, str(i, j))
        Next j
    Next i
End Sub
Sub tqs1(str1() As String, str() As String, ch() As String, mcs As Integer)
    Dim i As Integer, j As Integer, m As Integer, n1 As Integer
    m = UBound(str, 1): n1 = UBound(str, 2)
    ReDim str1(m - mcs + 1, n1 * mcs + 1) As String
    ReDim Preserve ch(m, n1 * mcs) As String
    ReDim str2(0) As String
    For i = 1 To mcs
        For j = 1 To n1
            If member1(str2, str(i, j) + ch(i, j)) = 1 Then
                ch(1, UBound(str2)) = ch(i, j)
            End If
        Next j
    Next i
    str1(1, n1 * mcs + 1) = UBound(str2)
    For j = 1 To str1(1, n1 * mcs + 1)
        str1(1, j) = str2(j)
    Next j
    For i = mcs + 1 To m
        ReDim str2(0) As String
        For j = 1 To n1
            If member1(str2, str(i, j) + ch(i, j)) = 1 Then
                ch(i - mcs + 1, UBound(str2)) = ch(i, j)
            End If
        Next j
        str1(i - mcs + 1, n1 * mcs + 1) = UBound(str2)
        For j = 1 To str1(i - mcs + 1, n1 * mcs + 1)
            str1(i - mcs + 1, j) = str2(j)
        Next j
    Next i
End Sub
Sub t(cl() As String, ch() As String, mcs As Integer, yljk As Single, ljjgsn As Single)
    ReDim r(0, 0) As String, r1(0) As String
    Dim tn As Integer, tm As Integer
    Dim i As Integer, j As Integer, v As Integer, v1 As Integer
    Dim colNI As Integer, colSL As Integer, colVN As Integer
    Dim lys As Single, zyd As Integer
    zyd = xlsheet1.Cells(16, "E")
    If zyd <> 0 Then
        Dim zydch(5) As Integer
        Call zydsj(zydch)
    End If
    lys = xlsheet1.Cells(18, "F")
    Call tqs1(r, cl, ch, mcs)
    Call tqs(r1, ch)
    ljyf colNI, colSL, colVN, yljk
    v = 0: tn = 0
    For i = 1 To UBound(r, 1)
        For j = 1 To r(i, UBound(r, 2))
            v = hang + tn + j
            If j = 1 And i = 1 Then
                xlsheet5.Cells(v, "A") = "合            计"
                If zqc <> 0 Then
                    xlsheet5.Cells(v, 18 + colVN) = "扣桥长" & zqc & "m。"
                End If
                xlsheet5.Cells(v, 16 + colVN) = wlcs
                If lys <> 0 Then
                    xlsheet5.Cells(v, "U") = "=Sum(U7:U" & v - 2 & ")"
                End If
                If yljk = 0 Then
                    xlsheet5.Cells(v, 14 + colVN) = r1(j)
                    xlsheet5.Cells(v, "O") = "=Sumif(N7" & ":N" & hang - 2 & ",N" & v & ",O7" & ":O" & hang - 2 & ")"
                    xlsheet5.Cells(v, 12 + colSL) = "=Sum(L7:L" & v - 2 & ")"
                    xlsheet5.Cells(v, 13 + colSL) = "=Sum(M7:M" & v - 2 & ")"
                '    xlsheet5.Cells(v, 20 + colVN) = "=Sum(T7:T" & v - 2 & ")"
                    xlsheet5.Cells(v, 17 + colVN) = "=Sum(Q7:Q" & v - 2 & ")"
                Else
                    xlsheet5.Cells(v, 12 + colSL) = "=Sum(S7:S" & v - 2 & ")"
                    xlsheet5.Cells(v, 13 + colSL) = "=Sum(T7:T" & v - 2 & ")"
                 '   xlsheet5.Cells(v, 20 + colVN) = "=Sum(AB7:AB" & v - 2 & ")"
                    xlsheet5.Cells(v, 17 + colVN) = "=Sum(Y7:Y" & v - 2 & ")"
                End If
            End If
            If zydch(j) <> 0 And i = 1 Then
                xlsheet5.Cells(v, "J") = zydch(j)
                xlsheet5.Cells(v, "R") = "=Sumif(AA7" & ":AA" & hang - 2 & ",AA" & v & ",R7" & ":R" & hang - 2 & ")"
            End If
            xlsheet5.Cells(hang + tn + j, "C") = r(i, j) & "cm"
            xlsheet5.Cells(hang + tn + j, 19 + colVN) = r(i, j)
            xlsheet5.Cells(hang + tn + j, 4 + i) = ch(i, j)
            If yljk = 0 Then
            xlsheet5.Cells(hang + tn + j, "K") = "=Sumif(S7" & ":S" & hang - 2 & ",S" & v & ",K7" & ":K" & hang - 2 & ")"
            xlsheet5.Cells(hang + tn + j, "B") = "=Sumif(S7" & ":S" & hang - 2 & ",S" & v & ",B7" & ":B" & hang - 2 & ")"
            Else
            xlsheet5.Cells(hang + tn + j, "P") = "=Sumif(AA7" & ":AA" & hang - 2 & ",AA" & v & ",P7" & ":P" & hang - 2 & ")"
            xlsheet5.Cells(hang + tn + j, "B") = "=Sumif(AA7" & ":AA" & hang - 2 & ",AA" & v & ",B7" & ":B" & hang - 2 & ")"
            End If
        Next j
        tn = tn + r(i, UBound(r, 2))
    Next i
        tt = tn
        Dim ccc As Integer
        If ljjgsn = 0 Then
            ccc = 1
        Else
            ccc = mcs + 1
        End If
        For j = ccc To UBound(r1)
            v1 = hang + j
            xlsheet5.Cells(v1, 14 + colVN) = r1(j)
            If yljk = 0 Then
                xlsheet5.Cells(v1, "O") = "=Sumif(N7" & ":N" & hang - 2 & ",N" & v1 & ",O7" & ":O" & hang - 2 & ")"
            Else
            xlsheet5.Cells(v1, "W") = "=Sumif(V7" & ":V" & hang - 2 & ",V" & v1 & ",W7" & ":W" & hang - 2 & ")"
            End If
        Next j
End Sub
Sub t1(cl() As String, ch() As String, mcs As Integer)
    ReDim r(0, 0) As String
    Dim tn As Integer
    Dim i As Integer, j As Integer, v As Integer
    Call tqs1(r, cl, ch, mcs)
    v = 0: tn = 0
    For i = 1 To UBound(r, 1)
        For j = 1 To r(i, UBound(r, 2))
            v = hang + tn + j
            xlsheet5.Cells(v, "K") = r(i, j) & "cm"
            xlsheet5.Cells(v, "M") = ch(i, j)
            xlsheet5.Cells(v, "AC") = r(i, j)
            xlsheet5.Cells(v, "Q") = "=Sumif(AC7" & ":AC" & hang - 2 & ",AC" & v & ",Q7" & ":Q" & hang - 2 & ")"
        Next j
        tn = tn + r(i, UBound(r, 2))
    Next i
End Sub

Function read_cl(cl() As String, ch() As String, zhn As Integer) As Integer
    Dim cs As Integer, zhs As Integer
    Dim i As Integer
    cs = UBound(cl, 1): zhs = UBound(cl, 2)
    read_cl = qcs(zhn)
        ReDim Preserve cl(10, zhs + 1)
        ReDim Preserve ch(10, zhs + 1)
    For i = 1 To read_cl
        cl(i, zhs + 1) = xlsheet1.Cells(23 + i, 1 + zhn * 2)
        ch(i, zhs + 1) = xlsheet1.Cells(23 + i, 2 + zhn * 2)
    Next i
End Function
Function qcs(zhn As Integer)
    qcs = 0
    Do While xlsheet1.Cells(24 + qcs, 1 + zhn * 2) <> Empty
        qcs = qcs + 1
    Loop
End Function
Function read_cllj(cl() As String, ch() As String, zhnlj As Integer) As Integer
    Dim cs As Integer, zhs As Integer
    Dim i As Integer
    cs = UBound(cl, 1): zhs = UBound(cl, 2)
    read_cllj = qcslj(zhnlj)
        ReDim Preserve cl(10, zhs + 1)
        ReDim Preserve ch(10, zhs + 1)
    For i = 1 To read_cllj
        cl(i, zhs + 1) = xlsheet1.Cells(34 + i, 1 + zhnlj * 2)
        ch(i, zhs + 1) = xlsheet1.Cells(34 + i, 2 + zhnlj * 2)
    Next i
End Function
Function qcslj(zhnlj As Integer)
    qcslj = 0
    Do While xlsheet1.Cells(35 + qcslj, 1 + zhnlj * 2) <> Empty
        qcslj = qcslj + 1
    Loop
End Function
Sub ljyf(colNI As Integer, colSL As Integer, colVN As Integer, yljk As Single)
    If yljk <> 0 Then
        colNI = 5
        colSL = 7
        colVN = 8
    Else
        colNI = 0
        colSL = 0
        colVN = 0
    End If
End Sub
Sub zydsj(zydch() As Integer)
    Dim ii As Integer
    ii = 1
    Do While xlsheet1.Cells(16, 4 + ii) <> Empty
        zydch(ii) = xlsheet1.Cells(16, 4 + ii)
        ii = ii + 1
    Loop
End Sub