tfdp1.bas

此程序是完成的土方调配

    xlbook.Application.Selection.RowHeight = 20
    xlsheet3.Rows(r2).Select
    xlbook.Application.Selection.RowHeight = 10
    xlbook.Application.ActiveWindow.SmallScroll Down:=32
    xlsheet3.Rows(r3).Select
    xlbook.Application.Selection.RowHeight = 20
    xlsheet3.Range(rr1).Select
End Sub
'拷贝整个表格到另一个新增的表格中。
Sub copy_bg1()
    xlsheet2.Activate
    xlsheet2.Select
    xlbook.Sheets.Add.Name = bg
    Set xlsheet3 = xlbook.Worksheets(bg)
    xlsheet1.Activate
    xlsheet1.Cells.Select
    xlsheet1.Application.Selection.Copy
    xlsheet1.Range("A1").Select
    xlsheet3.Select
    xlsheet3.Range("A1").Select
    xlbook.ActiveSheet.Paste
    xlsheet3.Range("A1").Select
End Sub
'该函数用于判断输入的工作薄名是否与原有的工作薄名相同
Function sgzb()
    Dim a
    On Error GoTo nnn
    If bg = "" Then
        sgzb = 1
    Else
        a = xlbook.Worksheets(bg).Cells(1, 1)
        sgzb = 1
    End If
    Exit Function
nnn:
    sgzb = 0
End Function
'页面设置
Sub ymsz()
    With xlbook.ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    xlbook.ActiveSheet.PageSetup.PrintArea = ""
    With xlbook.ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(1.37795275590551)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.590551181102362)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA3
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
    End With
End Sub
'真弃方的横向调配的子程序
Sub lyfqf(wts As Double, wss As Double, tfs As Double, zz As Integer, wfsl4 As Double, wfsl5 As Double, wfsl6 As Double)
    Dim qt As Double, qs As Double, qs4 As Double, qs5 As Double, qs6 As Double, yssl As Double
    Dim yt As Double, yss As Double, ys4 As Double, ys5 As Double, ys6 As Double
    If wts > 0 And wts <= 50 Then
        qt = wts
        yt = 0
    Else
        qt = Int(wts * qt1_3 + 0.5)
        yt = wts - qt
    End If
    If wfsl4 + wfsl5 + wfsl6 > 0 And wss <= 50 Then
        qs4 = wfsl4
        qs5 = wfsl5
        qs6 = wfsl6
        qs = wss
        yss = 0
    Else
        qs4 = Int(wfsl4 * qt4 + 0.5)
        qs5 = Int(wfsl5 * qt5 + 0.5)
        qs6 = Int(wfsl6 * qt6 + 0.5)
        ys4 = wfsl4 - qs4
        ys5 = wfsl5 - qs5
        ys6 = wfsl6 - qs6
        qs = qs4 + qs5 + qs6
        yss = wss - qs
    End If
    If qt <> 0 Then
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AD") = qt '弃土
    End If
    If qs <> 0 Then
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AE") = qs '弃石
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AO") = qs4 '弃4级土
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AP") = qs5 '弃5级土
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AQ") = qs6 '弃6级土
    End If
    
    If yt + yss > tfs Then
        If yt - tfs > 0 Then
            If tfs <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = tfs '本桩利用土
            End If
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Y") = yt - tfs '挖余土
            If yss <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Z") = yss '挖余石
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AL") = ys4 '挖余4级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AM") = ys5 '挖余5级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AN") = ys6 '挖余6级土
            End If
        ElseIf yt - tfs = 0 Then
            If yt <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = yt  '本桩利用土
            End If
            If yss <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Z") = yss '挖余石
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AL") = ys4 '挖余4级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AM") = ys5 '挖余5级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AN") = ys6 '挖余6级土
            End If
        ElseIf yt - tfs < 0 Then
            If yt <> 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = yt  '本桩利用土
            End If
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = tfs - yt  '本桩利用石
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Z") = yt + yss - tfs '挖余石
            If ys4 - (tfs - yt) >= 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AI") = tfs - yt  '用4级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AL") = ys4 - (tfs - yt) '余4级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AM") = ys5 '余5级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AN") = ys6 '余6级土
            ElseIf ys4 - (tfs - yt) < 0 And ys4 + ys5 - (tfs - yt) >= 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = yt  '本桩利用土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = tfs - yt  '本桩利用石
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AI") = ys4  '本桩利用石4
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AJ") = tfs - yt  '本桩利用石5
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Z") = yt + yss - tfs '挖余石
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AM") = ys4 + ys5 + yt - tfs '余5级土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AN") = ys6 '余6级土
            ElseIf ys4 + ys5 - (tfs - yt) < 0 And ys4 + ys5 + ys6 - (tfs - yt) >= 0 Then
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = yt  '本桩利用土
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = tfs - yt  '本桩利用石
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "Z") = yt + yss - tfs '挖余石
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AI") = ys4 '本桩利用石4
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AJ") = ys5  '本桩利用石5
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = tfs - yt - ys4 - ys5 '本桩利用石6
                xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AM") = ys4 + ys5 + ys6 + yt - tfs '余6级土
            End If
        End If
    ElseIf yt + yss = tfs Then
        If yt <> 0 Then
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = yt '本桩利用土
        End If
        If yss <> 0 And tfs <> 0 Then
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = yss '本桩利用石
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AI") = ys4 '本桩利用石4
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AJ") = ys5 '本桩利用石5
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AK") = ys6 '本桩利用石6
        End If
    ElseIf yt + yss < tfs Then
        If yt <> 0 Then
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "U") = yt '本桩利用土
        End If
        If yss <> 0 And tfs <> 0 Then
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = yss '本桩利用石
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "V") = yss  '本桩利用石
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AI") = ys4 '本桩利用石4
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AJ") = ys5  '本桩利用石5
            xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AK") = ys6  '本桩利用石6
        End If
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "W") = tfs - yt - yss
        xlsheet3.Cells((ys - 1) * 64 + 5 + zz * 2, "AB") = tfs - yt - yss '借方本桩利用石
    End If
End Sub

Sub mglhj(ys As Integer, glys As Integer)
    Dim hangs() As Integer, i As Integer, k As Integer, j As Integer
    Dim glhj(40) As String, strs(40) As Integer
    For i = 1 To 23
        glhj(i) = ""
        For k = 1 To glys
            ReDim hangs(k)
            hangs(k) = ys * 64 - (k - 1) * 64 - 2
            glhj(i) = Chr(67 + i) & hangs(k) & "," & glhj(i)
        Next k
        strs(i) = Len(glhj(i))
        glhj(i) = Left(glhj(i), strs(i) - 1)
        glhj(i) = "=if(Sum(" & glhj(i) & ")=0,""""," & "Sum(" & glhj(i) & "))"
    Next i
    For i = 24 To 40
        glhj(i) = ""
        For k = 1 To glys
            ReDim hangs(k)
            hangs(k) = ys * 64 - (k - 1) * 64 - 2
            glhj(i) = Chr(65) & Chr(41 + i) & hangs(k) & "," & glhj(i)
        Next k
        strs(i) = Len(glhj(i))
        glhj(i) = Left(glhj(i), strs(i) - 1)
        glhj(i) = "=if(Sum(" & glhj(i) & ")=0,""""," & "Sum(" & glhj(i) & "))"
    Next i
    For j = 1 To 40
        xlsheet3.Cells((ys - 1) * 64 + 63, 3 + j) = glhj(j)
    Next j
End Sub
'查看表格的子程序
Sub ckbg()
    Load Form2
    Form2.Show
    Form1.Hide
    xlbook.Application.Visible = True
    xlbook.Windows(1).Visible = True
    xlbook.Application.WindowState = xlMaximized
End Sub