請幫幫忙，寫個VBA的程序，謝謝

妳的表述真暈，幾句話搞定的東西，說這麽多，暈了頭了。

妳只要說：

sheet1表中的數據按D列順序相加小於等於50且不大於30行分按sheet2格式建立若幹工作表，每增加壹個表按B3遞增，批+1，把相就數據寫入分表中並求出面積，數量與面積求和。具體見表（我傳給妳）。

呵呵，已經發妳郵箱，請查收。妳所說的矩形改為文本框。 考慮到拆分過會重名錯誤，建立了壹個刪除原拆分的分表代碼。

代碼如下：

Sub 拆分工作表()

Dim G1&, i&, iR&, R1&, x&, N&

Dim T1$, T2$

Dim arr, arr1()

With Sheets("sheet1")

iR = .Range("A65536").End(xlUp).Row

arr = .Range("A2:D" & iR).Value

End With

i = 2: N = 1: R1 = 1

G1 = Sheets.Count

If G1 > 2 Then MsgBox "妳已經執行過了！": End

T1 = Sheets("sheet2").Range("B3")

T2 = Left(T1, Len(T1) - 3) & Right(T1, 3) + i

Sheets("sheet2").Copy after:=Sheets(G1)

With ActiveSheet

.Range("B3") = T2

ActiveSheet.Name = T2

ActiveSheet.TextBox1.Value = .TextBox1.Text + N

End With

Do While R1 <= UBound(arr)

Xia:

k = k + arr(R1, 4)

If k <= 50 And x <= 30 Then

x = x + 1

ReDim Preserve arr1(1 To 5, 1 To x)

arr1(1, x) = arr(R1, 1)

arr1(2, x) = arr(R1, 2)

arr1(3, x) = arr(R1, 3)

arr1(4, x) = arr(R1, 4)

arr1(5, x) = arr1(2, x) * arr1(3, x) * arr1(4, x) / 1000000

h1 = h1 + arr1(4, x)

h2 = h2 + arr1(5, x)

R1 = R1 + 1

Else

Range("B6").Resize(UBound(arr1, 2), 5) = Application.Transpose(arr1)

Range("E36") = h1

Range("F36") = h2

G1 = G1 + 1 : N = N + 1 : i = i + 2 : x = 0 : h1 = 0 : h2 = 0 : k = 0

Erase arr1

Sheets("sheet2").Copy after:=Sheets(G1)

With ActiveSheet

T2 = Left(T1, Len(T1) - 3) & Right(T1, 3) + i

.Range("B3") = T2

ActiveSheet.Name = T2

ActiveSheet.TextBox1.Value = .TextBox1.Text + N

End With

GoTo Xia

End If

Loop

Range("B6").Resize(UBound(arr1, 2), 5) = Application.Transpose(arr1)

Range("E36") = h1

Range("F36") = h2

ActiveWorkbook.Save

End Sub

Sub 刪除折分表()

Dim x&

If Sheets.Count > 2 Then

For x = Sheets.Count To 3 Step -1

Application.DisplayAlerts = False

Sheets(x).Delete

Application.DisplayAlerts = True

Next x

Else

MsgBox "妳還沒進行拆分，不能刪除！": End

End If

End Sub