vba如何平差？

sblisb

保留两位数，同一编号地块面积拆分后要保持不变，不一样要平差

平差方法为：
1、先按占比重算面积："拆分后面积"/"拆分后同一编号地块总面积"*原面积。
2、”重算后的同一编号总面积”再与原面积求出差值，差值再按0.01为单位，按拆分的面积从大到小排序，分配给拆分后各地块，如为0.01，则分配3片.各加0.01.
面积_平差.zip (13.55 KB, 下载次数: 11)

2023-1-7 18:35 上传

点击文件名下载附件

于箱长

这道题好像特别专业，个人理解不了平差的概念，路过吧

sblisb

于箱长 发表于 2023-1-7 19:50
这道题好像特别专业，个人理解不了平差的概念，路过吧

表中已写好计算公式

你地铁图

分配残差没有公式

你地铁图

帖子留的就不大好 把该不该给的问题全留给帮忙的人了  公式最好还是用语言描述一下

zxsea_7426

现在不能截图就直接上代码。反正根据原表意思写的。代码有点啰嗦：

Sub TEST()
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    With Sheets("GHZLKJ_平差")
        ar = .[a1].CurrentRegion
    End With
'==========================================以下工作表为过渡用或者另用也可===================================
'=========================================================================================================
    With Sheets("结果")
        .[a1].Resize(UBound(ar), 1).NumberFormatLocal = "@"
        .[c1].Resize(UBound(ar), 1).NumberFormatLocal = "_0.00"
        .[a1].Resize(UBound(ar), UBound(ar, 2)) = ar
        .[a1].Resize(UBound(ar), UBound(ar, 2)).Offset(1, 3).ClearContents
        .[h1].Resize(UBound(ar), 1) = Application.WorksheetFunction.Index(ar, 0, 8)
        .[a1].CurrentRegion.Sort key1:=.[a2], order1:=2, key2:=.[d2], order2:=2, Header:=xlYes
        ar = .[a1].CurrentRegion
        For i = 2 To UBound(ar)
            d(ar(i, 1)) = d(ar(i, 1)) + ar(i, 3)        '拆分后面积
        Next i
        For i = 2 To UBound(ar)
            按比例分配面积 = ar(i, 2) * ar(i, 3) / d(ar(i, 1))
            ar(i, 4) = WorksheetFunction.Round(按比例分配面积, 2)
            d1(ar(i, 1)) = d1(ar(i, 1)) + ar(i, 4)  '按比例分配面积
        Next i
        For i = 2 To UBound(ar)
            ar(i, 5) = WorksheetFunction.Round((ar(i, 2) - d1(ar(i, 1))), 2)   '原面积-按比例分配面积 [即残差]
            If Not d2.exists(ar(i, 1)) Then
                ar(i, 6) = ar(i, 5)
                d2(ar(i, 1)) = Int(ar(i, 5) * 100) 'WorksheetFunction.RoundUp(ar(i, 5), 2) '待分配残值
            End If
'=======================根据残值进行分配===========================
'            ar(i, 5) = Int((ar(i, 2) - d1(ar(i, 1))) * 100) / 100
'            '发现0.03分配不均，固将残值修为放大100倍后取整
            If d2(ar(i, 1)) > 0 Then
                ar(i, 9) = ar(i, 4) + 0.01
                d2(ar(i, 1)) = d2(ar(i, 1)) - 1
                ar(i, 7) = 0.01
            ElseIf d2(ar(i, 1)) < 0 Then
                ar(i, 9) = ar(i, 4) - 0.01
                d2(ar(i, 1)) = d2(ar(i, 1)) + 1
                ar(i, 7) = -0.01
            
            ElseIf d2(ar(i, 1)) = 0 Then
                ar(i, 9) = ar(i, 4)
            End If
'==================================================================
        Next i
        Sheets("结果").[a1].Resize(UBound(ar), UBound(ar, 2)) = ar
        d.RemoveAll
        d1.RemoveAll
        d2.RemoveAll
        For i = 2 To UBound(ar)
            d(ar(i, 1) & "##" & ar(i, 3)) = ar(i, 9)
        Next i
    End With
'=========================================================================================================
'=========================================================================================================


'原表写入VBA平差面积==================================
        br = Sheets("GHZLKJ_平差").[a1].CurrentRegion
        For i = 2 To UBound(br)
            br(i, 9) = d(br(i, 1) & "##" & br(i, 3))
        Next i
        Sheets("GHZLKJ_平差").[i1].Resize(UBound(br), 1) = Application.WorksheetFunction.Index(br, 0, 9)
        d.RemoveAll
'====================================================
End Sub

zxsea_7426

继续凑热闹，看客多我一个不多

sblisb

zxsea_7426 发表于 2023-1-7 23:50
继续凑热闹，看客多我一个不多

完美解决问题