仓库质心VBA

我正在试图写一个公式，考虑到“x”地址的客户数量和他们订购的数量（'q'）。 然后我想要公式打印出“质心”仓库应该是的最佳位置的纬度/经度。

我更喜欢它是一个命令，如=getCentroid 。

谢谢你的帮助。

编辑

由于有些人可能会认为这个代码太宽泛，或者没有足够的信息，所以我会提供一个旧代码。

这个代码需要我input的纬度和经度，然后考虑运输的数量，然后继续告诉我新的仓库应该在哪里。 这是如此古老，我不知道它是如何工作的。

 Private Sub CommandButton1_Click() Dim i As Integer Dim j As Integer Dim count As Integer i = 3 j = 0 count = 3 dtr = 0.0174533 'degrees to radians calculation RTD = 57.2958 'radians to degrees LatFactor = 69.172 'miles in 1 degree change in lat 'Finds how many locations there are around whs as j Do While Cells(i, 2) <> "" j = j + 1 lats = lats + Cells(i, 2) Longs = Longs + Cells(i, 3) i = i + 1 Loop 'Create arrays of lats and longs starting at 0 Dim lat() As Variant ReDim lat(0 To j) Dim lon() As Variant ReDim lon(0 To j) For x = 1 To j lat(count - 3) = Cells(count, 2) lon(count - 3) = Cells(count, 3) count = count + 1 Next R = 3959 'Radius of earth whsLat = Cells(2, 2) 'Lattitude of Whs in NOT Radians whsLon = Cells(2, 3) 'Lattitude of whs NOT in rads whsLatr = Cells(2, 2) * dtr whsLonr = Cells(2, 3) * dtr 'Calculates distance from warehouse to location 1 as d 'uses haversine formula-as crow flies Dim Distances() As Variant ReDim Distances(0 To j) For x = 1 To j Clat = lat(x - 1) * dtr deltaLat = (lat(x - 1) - whsLat) * dtr deltaLon = (lon(x - 1) - whsLon) * dtr a = (Math.Sin(deltaLat / 2) * Math.Sin(deltaLat / 2)) + (Math.Cos(whsLatr) * Math.Cos(Clat) * Math.Sin(deltaLon / 2) * Math.Sin(deltaLon / 2)) c = 2 * Math.Atn((Math.Sqr(a) / Math.Sqr(1 - a))) d = R * c Distances(x - 1) = d 'distance values Cells(x + 2, 13) = d Next TotalMiles = WorksheetFunction.Sum(Distances) step = 1 'Calculate optimum location using halves Olat = lat(0) Olon = lon(0) OLatr = lat(0) * dtr OLonr = lon(0) * dtr Dlat = lat(1) DLatr = lat(1) * dtr Dlon = lon(1) Dlonr = lon(1) * dtr LatChange = (lat(1) - Olat) * dtr LonChange = (lon(1) - Olon) * dtr 'Counting Variables for weight y = 3 Z = 4 ShipSum = Cells(y, 4) + Cells(Z, 4) For x = 1 To j - 1 anew = (Math.Sin(LatChange / 2) * Math.Sin(LatChange / 2)) + (Math.Cos(OLatr) * Math.Cos(DLatr) * Math.Sin(LonChange / 2) * Math.Sin(LonChange / 2)) cnew = 2 * Math.Atn((Math.Sqr(anew) / Math.Sqr(1 - anew))) dnew = R * cnew 'Calculate new lat and long hyp = dnew / 2 ' Total distance moved adj = Abs(LatFactor * (Dlat - Olat)) 'y distance Degree = WorksheetFunction.Acos(adj / dnew * dtr) 'degree from 90 If (Dlat - Olat) > 0 Then NewLat = Olat + (Cells(Z, 4) / (ShipSum)) * Abs(hyp / LatFactor * Math.Cos(Degree) * RTD) 'New lattitude if going up If (Dlat - Olat) < 0 Then NewLat = Olat - (Cells(Z, 4) / (ShipSum)) * Abs(hyp / LatFactor * Math.Cos(Degree) * RTD) 'New Lattitude if going down Opp = (Dlon - Olon) * Math.Cos(NewLat * dtr) 'x distance adjusted for polar flattening If (Dlon - Olon > 0) Then NewLon = Olon + (Cells(Z, 4) / (ShipSum)) * Abs(Opp) 'new long If (Dlon - Olon < 0) Then NewLon = Olon - (Cells(Z, 4) / (ShipSum)) * Abs(Opp) Olat = NewLat 'Setting new origin Olon = NewLon OLatr = NewLat * dtr OLonr = NewLon * dtr If x < j Then Dlat = lat(x + 1) 'If there is another iteration, set new destination DLatr = lat(x + 1) * dtr Dlon = lon(x + 1) Dlonr = lon(x + 1) * dtr LatChange = (lat(x + 1) - Olat) * dtr LonChange = (lon(x + 1) - Olon) * dtr y = y + 1 Z = Z + 1 ShipSum = ShipSum + Cells(Z, 4) End If Next Cells(3, 8) = NewLat Cells(3, 9) = "-" & NewLon whsLat = NewLat 'Lattitude of New Whs in NOT Radians whsLon = NewLon 'Lattitude of whs NOT in rads whsLatr = NewLat * dtr whsLonr = NewLon * dtr 'Calculates distance from warehouse to location 1 as d 'uses haversine formula-as crow flies Dim NewDistances() As Variant ReDim NewDistances(0 To j) For x = 1 To j Clat = lat(x - 1) * dtr deltaLat = (lat(x - 1) - whsLat) * dtr deltaLon = (lon(x - 1) - whsLon) * dtr a = (Math.Sin(deltaLat / 2) * Math.Sin(deltaLat / 2)) + (Math.Cos(whsLatr) * Math.Cos(Clat) * Math.Sin(deltaLon / 2) * Math.Sin(deltaLon / 2)) c = 2 * Math.Atn((Math.Sqr(a) / Math.Sqr(1 - a))) d = R * c Cells(x + 2, 10) = d NewDistances(x - 1) = d 'distance values Next NewTotalMiles = WorksheetFunction.Sum(NewDistances) Cells(j + 3, 10) = NewTotalMiles Worksheets("Sheet1").Range("K3:K100").ClearContents i = 3 Do While i < 44 Cells(i, 11) = Cells(i, 10) * Cells(i, 4) i = i + 1 Loop Cells(11, 11) = Cells(3, 11) + Cells(4, 11) + Cells(5, 11) + Cells(6, 11) + Cells(7, 11) + Cells(8, 11) + Cells(9, 11) + Cells(10, 11) End Sub 

Answer 1

下面是一些处理球体表面加权质心math部分的代码：

 'the following code assumes that A is a 4 column, 1-based, 2-dimensional array whose 'first three columns are the x,y,z coordinats of a point on a sphere centered at the origin 'and whose 4th column is the mass at that point 'returns a 0-based variant array of the x,y,z coordinates of the centroid Function SphericalCentroid(A As Variant) As Variant Dim r As Double 'radius of sphere Dim pm As Double 'point-mass Dim m As Double 'total mass Dim mxy As Double, mxz As Double, myz As Double 'moments about coordinate planes Dim xbar As Double, ybar As Double, zbar As Double 'true centroid Dim d As Double 'distance of true centroid from center -- used to project to surface Dim i As Long, n As Long If TypeName(A) = "Range" Then A = A.Value n = UBound(A) r = Sqr(A(1, 1) ^ 2 + A(1, 2) ^ 2 + A(1, 3) ^ 2) For i = 1 To n pm = A(i, 4) m = m + pm myz = myz + pm * A(i, 1) mxz = mxz + pm * A(i, 2) mxy = mxy + pm * A(i, 3) Next i xbar = myz / m ybar = mxz / m zbar = mxy / m d = Sqr(xbar ^ 2 + ybar ^ 2 + zbar ^ 2) If d < 0.001 * r Then 'located at the center -- return pole SphericalCentroid = Array(0, 0, r) Else SphericalCentroid = Array(xbar * r / d, ybar * r / d, zbar * r / d) End If End Function 

以下屏幕截图显示了如何使用它：

在上面我在单元格A5:C5 （使用Ctrl + Shift + Enter ）中使用了数组公式（ =SphericalCentroid(A2:D4) ）。

代码首先计算三维空间中的质心（将其定位在球体内部的某个位置），然后将其投影到球体上。

为了解决您的问题，您需要创build一个包装函数，该函数将经纬度转换为笛卡尔坐标（将地球近似为球体 – 确实存在问题），调用上述函数，然后转换回经/纬度。

在编辑为了好玩，我写了一个包装函数：

 'the following function takes a 3-column range, the first column is decimal latitude, 'the second is decimal longitude (assuming in North America), 'the third is number of shipments from that location 'the return value is the decimal latitude and longitude of 'the centroid Function GetCentroid(data As Range) As Variant Dim r As Double Dim lat As Double, lon As Double Dim x As Double, y As Double, z As Double Dim A As Variant Dim i As Long, n As Long Dim centroid As Variant r = 3959 'radius of earth n = data.Rows.Count ReDim A(1 To n, 1 To 4) With Application.WorksheetFunction For i = 1 To n lat = .Radians(data.Cells(i, 1).Value) lon = .Radians(data.Cells(i, 2).Value) A(i, 1) = r * Cos(lat) * Cos(lon) A(i, 2) = r * Cos(lat) * Sin(lon) A(i, 3) = r * Sin(lat) A(i, 4) = data.Cells(i, 3).Value Next i centroid = SphericalCentroid(A) x = centroid(0) y = centroid(1) z = centroid(2) lat = .Degrees(.Asin(z / r)) lon = .Degrees(.Atan2(x, y)) End With GetCentroid = Array(lat, lon) End Function 

用于：

input列表中的三个位置分别位于克利夫兰，辛辛那提和匹兹堡，返回的质心位于俄亥俄州中部（与赞斯维尔有点接近 – 这看起来似乎足够合理）。

我怀疑它比粗略的启发式更好，但是它给出了一个好的位置的概念。