[求助]Excel汇总表拆分明细表

一个简单的转置问题而已
上个附件到百度网盘，不太可能给你模拟表格的，何况你这列标都掐头去尾的。

Option Explicit
Sub abc()
　Dim a, i, j, k, m
　a = Sheets("汇总").[a1].CurrentRegion.Offset(2).Value
　If (UBound(a, 2) - 2 - 1) Mod 4 Then MsgBox "!": Exit Sub
　Call doevent(False)
　For Each i In Sheets
　　If i.Name <> "汇总" Then i.Delete
　Next
　For i = 1 To UBound(a) - 2
　　a(i, UBound(a, 2) - 1) = Replace(a(i, UBound(a, 2) - 1), "]", ")")
　　a(i, UBound(a, 2) - 1) = Replace(a(i, UBound(a, 2) - 1), "[", "(")
　　a(i, UBound(a, 2) - 1) = LCase(a(i, UBound(a, 2) - 1))
　Next
　Call qsort(a, 1, UBound(a) - 2, 1, UBound(a, 2), UBound(a, 2) - 1)
　ReDim b(UBound(a), 5)
　j = Split("序号,名称,开始时间,作业时间,作业内容,周期", ",")
　For i = 0 To UBound(j)
　　b(0, i) = j(i)
　Next
　For i = 1 To UBound(a, 1) - 2
　　If Len(a(i, UBound(a, 2) - 1)) Then
　　　For j = 2 To UBound(a, 2) - 2 Step 4
　　　　If Len(a(i, j)) Then
　　　　　m = m + 1
　　　　　b(m, 0) = m: b(m, 1) = a(i, UBound(a, 2) - 1)
　　　　　For k = j To j + 3
　　　　　　b(m, k - j + 2) = a(i, k)
　　　　　Next
　　　　End If
　　　Next
　　　If a(i, UBound(a, 2) - 1) <> a(i + 1, UBound(a, 2) - 1) Then
　　　　Sheets.Add
　　　　With ActiveSheet
　　　　　.Name = a(i, UBound(a, 2) - 1)
　　　　　.[c:d].NumberFormatLocal = "yyyy.mm.dd"
　　　　　With .[a1].Resize(m + 1, 6)
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　.Value = b
　　　　　End With
　　　　　.Columns(1).Resize(, 6).AutoFit
　　　　End With
　　　　m = 0
　　　End If
　　End If
　Next
　Call doevent(True)
End Sub
Function doevent(flag As Boolean)
　With Application
　　.DisplayAlerts = flag
　　.ScreenUpdating = flag
　End With
End Function
Function qsort(a, first, last, left, right, key)
　Dim i As Long, j As Long, k As Long, x, t
　i = first: j = last: x = a((first + last) \ 2, key)
　While i <= j
　　While a(i, key) < x: i = i + 1: Wend
　　While x < a(j, key): j = j - 1: Wend
　　If i <= j Then
　　　For k = left To right
　　　　t = a(i, k): a(i, k) = a(j, k): a(j, k) = t
　　　Next
　　　i = i + 1: j = j - 1
　　End If
　Wend
　If first < j Then qsort a, first, j, left, right, key
　If i < last Then qsort a, i, last, left, right, key
End Function

回复 🌴菠萝蜜🌴 :大佬大佬 帮忙改个公式 其中一个C列的 PL 是提取全部 我只想提取PL16~30
因为实际价格不一样 要怎么弄 原公式这样的 =IF(ISERR(FIND("PL",C3)),F3*G3*L3/1000,D3*E3*F3*G3*7.85/1000000)

'你这公式我根本看不来，应该是体积*密度/10^6(mm->mg/dm->kg)
'输出到Q列，感觉应该是差不多的
Option Explicit
Sub abc()
　Dim i, a, p, sum, t
　a = Range("a3:g" & [c3].End(xlDown).Row + 1).Value
　For i = 2 To UBound(a) - 1
　　t = Split(a(i, 3), "*")
　　If t(0) >= "PL16" And t(0) <= "PL30" Then '限定条件
　　　sum = sum + a(i, 7) * 7.85 * Mid(t(0), 3) * t(1) * a(i, 6) / 10 ^ 6
　　End If
　　If Len(a(i + 1, 1)) > 0 Or i = UBound(a) - 1 Then
　　　a(p + 1, 1) = Round(sum, 2): sum = 0
　　　p = i: i = i + 1
　　End If
　Next
　[q3].Resize(UBound(a) - 1) = a
End Sub

回复 🌴菠萝蜜🌴 :大佬 计算结果是大致对的 就是让没有这些板的计算结果用空格表示 而不是0 同事说16 18算一档 20往上的才是 一档 稍微改了一下

Sub abc()
Dim i, a, p, sum, t
a = Range("a3:g" & [c3].End(xlDown).Row + 1).Value
For i = 2 To UBound(a) - 1
t = Split(a(i, 3), "*")
If t(0) >= "PL16" And t(0) <= "PL19" Then '限定条件
sum = sum + a(i, 7) * 7.85 * Mid(t(0), 3) * t(1) * a(i, 6) / 10 ^ 6
End If
If Len(a(i + 1, 1)) > 0 Or i = UBound(a) - 1 Then
a(p + 1, 1) = Round(sum, 2): sum = 0
p = i: i = i + 1
End If
Next
[m3].Resize(UBound(a) - 1) = a
For i = 2 To UBound(a) - 1
t = Split(a(i, 3), "*")
If t(0) >= "PL20" And t(0) <= "PL50" Then '限定条件
sum = sum + a(i, 7) * 7.85 * Mid(t(0), 3) * t(1) * a(i, 6) / 10 ^ 6
End If
If Len(a(i + 1, 1)) > 0 Or i = UBound(a) - 1 Then
a(p + 1, 1) = Round(sum, 2): sum = 0
p = i: i = i + 1
End If
Next
[n3].Resize(UBound(a) - 1) = a
End Sub

又变卦了 说要14一列 16-18一列 20以上一列 这代码是真不会改了

然后让也有这些厚度的结果是空格 不是0

'分段汇总于A列非空行
Option Explicit
Sub abc()
　Dim i, j, a, p, t, m, n
　a = Range("a3:g" & [c3].End(xlDown).Row + 1).Value
　ReDim b(1 To UBound(a) - 1, 1 To 3), sum(3)
　For i = 2 To UBound(a) - 1
　　t = Split(a(i, 3), "*")
　　If InStr(t(0), "PL") = 1 Then
　　　n = Val(Mid(t(0), 3))
　　　If n = 14 Then
　　　　m = 1
　　　ElseIf n >= 16 And n < 20 Then
　　　　m = 2
　　　ElseIf n >= 20 Then
　　　　m = 3
　　　End If
　　　If m > 0 Then
　　　　b(i, m) = Round(a(i, 7) * 7.85 * Mid(t(0), 3) * _
　　　　　t(1) * a(i, 6) / 10 ^ 6, 2)
　　　　sum(m) = sum(m) + b(i, m)
　　　　m = 0
　　　End If
　　End If
　　If Len(a(i + 1, 1)) > 0 Or i = UBound(a) - 1 Then
　　　For j = 1 To 3
　　　　If sum(j) <> 0 Then
　　　　　b(p + 1, j) = Round(sum(j), 2): sum(j) = 0
　　　　End If
　　　Next
　　　p = i: i = i + 1
　　End If
　Next
　[q3].Resize(UBound(b), 3) = b
End Sub

红色区域是构件的件数 咱这个算好 只有单重 应该让他们算上构件的数量 黄色区域的数据可以不要 在绿色区域 显示整个工程里 这个尺寸的全部重量 假设 这工程只有这2件东西 那绿色区域就显示为1361.6 121.6 8068.8