|
- Sub 按钮1_Click()
- Dim ar, cc&
- ReDim ar(1 To 4, 1 To 1)
- cc = 1
- For i = 1 To 4
- Dim rng As Range, stra$, strb$, strc$, c&
- stra = ""
- strb = ""
- strc = ""
- Set rng = Range("A" & i).MergeArea
- ReDim Preserve ar(1 To 4, 1 To cc)
- ar(1, cc) = Range("A" & i).Text
- k = 1
- c = 0
- For j = i To i + rng.Count - 1
- Do While k <= c + Val(Split(Split(Range("B" & j).Text, "@")(1), "(")(0))
- If stra = "" Then
- stra = "H" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(2)
- strb = "W" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(1)
- strc = "L" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(0)
- Else
- stra = stra & "," & "H" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(2)
- strb = strb & "," & "W" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(1)
- strc = strc & "," & "L" & k & ":" & Split(Split(Range("B" & j).Text, "@")(0), "×")(0)
- End If
- k = k + 1
- Loop
- c = k - 1
- Next j
- ar(2, cc) = stra
- ar(3, cc) = strb
- ar(4, cc) = strc
- i = i + rng.Count - 1
- cc = cc + 1
- Next i
- Sheet1.Range("A" & 9).Resize(UBound(ar, 2), UBound(ar)) = Application.Transpose(ar)
- End Sub
复制代码 |
|