[已解决]求将三列插值成二维表的VBA代码

克鲁德007

原始为三列数，想把它插值成二维表；第一列为二维表的列标（范围为最大值和最小值，步长可以设置）；第二列为行标（范围最大值和最小值，步长可以设置），第三列为黄色区域。

见附件：
将三列插值成二维表.rar (12.8 KB, 下载次数: 19)

2015-8-17 23:20 上传

点击文件名下载附件
先谢谢大神了！

最佳答案

月排行榜 / 总排行榜

香川群子

2015-8-20 13:43

按近似区域直线拟合计算的代码，结果如下：

算法原理如下：
① 原始数据排序
② 依照每一个列标值，计算对应二维表指定步长范围行值对应的直线拟合值。
  具体的步骤是：
  ③ 查找最接近指定行标值对应的2个实际行值i1、i2
  ④ 计算y=kx+b 其中k、b由i1、i2对应的第2列值为x、第3列值为y
   ⑤ 以上全部该列标值对应的指定行标值计算完成后，进入下一个列标值。
⑥ 全部列标值计算完成后，依次检查指定步长的标准列标值范围，
  按几乎同样的原理，计算列标值对应的数据，填入二维表。

具体步骤略。

最后输出结果到工作表。

跳转到最佳答案楼层

爱疯

Sub test1()
    Dim rng As Range
    Dim pc As PivotCache
    Dim pt As PivotTable

    Set rng = Sheets(1).Range("a2:c" & Sheets(1).Range("a65536").End(xlUp).Row)
    Sheets.Add after:=Sheets(Sheets.Count)
    '创建 数据透视表的缓存（PivotCache 对象）
    Set pc = ThisWorkbook.PivotCaches.Create(xlDatabase, rng, 1)

    Set pt = pc.CreatePivotTable([A1])
    With pt
        .PivotFields("A").Orientation = xlColumnField
        .PivotFields("B").Orientation = xlRowField
        .PivotFields("C").Orientation = xlDataField
        .ColumnGrand = False '隐藏列总计
        .RowGrand = False '隐藏行总计
    End With
    Range("a1").CurrentRegion.EntireColumn.AutoFit
End Sub

将三列插值成二维表2.rar (22.21 KB, 下载次数: 10)

2015-8-18 08:54 上传

点击文件名下载附件




这样可以吗？

最好手动创建透视表，再调整。

suye1010

1. Option Explicit
   
2. Sub ReorganizeData()
   
3. Dim arrR(), arrC(), arr, arrO, TRs As Integer, TCs As Integer, i As Integer, j As Integer, Multiple As Integer
   
4. Multiple = InputBox("请输入你要设置的步长", "步长设置", 5)
   
5. If Len(Multiple) = 0 Then Exit Sub
   
6. i = 0
   
7. Do
   
8.     i = i + 1
   
9.     ReDim Preserve arrC(1 To i)
   
10.     arrC(i) = Application.WorksheetFunction.MRound(Application.WorksheetFunction.Min(Range("A:A")), Multiple) + (i - 1) * Multiple
    
11. Loop Until arrC(i) = Application.WorksheetFunction.MRound(Application.WorksheetFunction.Max(Range("A:A")), Multiple)
    
12. i = 0
    
13. Do
    
14.     i = i + 1
    
15.     ReDim Preserve arrR(1 To i)
    
16.     arrR(i) = Application.WorksheetFunction.MRound(Application.WorksheetFunction.Min(Range("B:B")), Multiple) + (i - 1) * Multiple
    
17. Loop Until arrR(i) = Application.WorksheetFunction.MRound(Application.WorksheetFunction.Max(Range("B:B")), Multiple)
    
18. arr = Range("A3:C" & Range("A65536").End(xlUp).Row)
    
19. ReDim arrO(1 To UBound(arrR), 1 To UBound(arrC))
    
20. For j = 1 To UBound(arr)
    
21.     arrO(Application.WorksheetFunction.Match(Application.WorksheetFunction.MRound(arr(j, 2), Multiple), arrR, 0), Application.WorksheetFunction.Match(Application.WorksheetFunction.MRound(arr(j, 1), Multiple), arrC, 0)) = arr(j, 3)
    
22. Next j
    
23. Range("D2:D65536,E1:AZ65536").Clear
    
24. Range("D2").Offset(0, 1).Resize(1, UBound(arrC)) = arrC
    
25. Range("D2").Offset(1, 0).Resize(UBound(arrR), 1) = Application.Transpose(arrR)
    
26. Range("D2").Offset(1, 1).Resize(UBound(arrO), UBound(arrO, 2)) = arrO
    
27. End Sub
    

复制代码

gufengaoyue

试试看。
将三列插值成二维表.rar (25.3 KB, 下载次数: 16)

2015-8-18 11:52 上传

点击文件名下载附件

克鲁德007

suye1010 发表于 2015-8-18 11:20

谢谢你的答复，而我需要的是每一个步长（A，B都有对应的C）都有值存在。中间不应该有空值。画出来的是个曲面。

让我学习了

克鲁德007

爱疯 发表于 2015-8-18 08:55
Sub test1()
    Dim rng As Range
    Dim pc As PivotCache

白天公司不能上网，回复慢了请见谅，谢谢你的答复。你的代码和我想要的有区别。

克鲁德007

gufengaoyue 发表于 2015-8-18 11:52
试试看。

非常感谢你的答复，你的代码非常接近我的需求。
1、但是不应该出现空值。

2、三列数的三点分布

3、通过你的代码的到的是这样的。

4、我想要的是所有的步长都有对应的值

上清宫主

只能怪楼主。你看你里面解释清楚了吗？也许你相当清楚，可别人能看懂吗？而且你连个示例也不做个出来。
看到你说的“插值”，可又象是表格的变形。究竟是什么？真的搞不懂

克鲁德007

上清宫主 发表于 2015-8-19 08:59
只能怪楼主。你看你里面解释清楚了吗？也许你相当清楚，可别人能看懂吗？而且你连个示例也不做个出来。
看 ...

谢谢了！确实有点不清楚。我想做的是有发动机的万有特性数据转速，扭矩，比油耗(三列数)原始数据，现有不在原始数据中的转速和扭矩，怎么插值比油耗出来。

爱疯

克鲁德007 发表于 2015-8-19 22:08
谢谢了！确实有点不清楚。我想做的是有发动机的万有特性数据转速，扭矩，比油耗(三列数)原始数据，现有不 ...

1）没理解步长，围观来学习。
2）可以上传7楼图片2的excel文件吗？为了看下图2的图表