Airman
Lv 4
Airman asked in 電腦與網際網路程式設計 · 1 decade ago

VBA~如何將無顯示需求之數值的欄位或活頁或效果檔刪除?

如題~

範例附檔︰http://www.funp.net/305847

原效果檔詳如︰TEST_S_2_524 ,TEST_S_2_525,TEST_S_2_526。

現想將效果檔改為~

以T7公式的計算區域的有無顯示數值為標準依據︰

T欄及其右邊各欄,以欄為單位,其第7列(含)以下有顯示任一數值者,保留其欄位。

反之,其第7列(含)以下無顯示任一數值之欄位者刪除,

且當該Sheet的T欄及其右邊各欄之欄位,其第7列(含)以下全無顯示任一數值時,則該Sheet刪除。

又當Sheet1~ Sheet7的T欄及其右邊各欄之欄位,如果其第7列(含)以下全無顯示任一數值則整個檔案刪除。

詳如︰

TEST_S_2_524(新需求之效果檔)& TEST_S_2_526(新需求之效果檔);

TEST_S_2_525為屬前述的最末項情況,故無TEST_S_2_525(新需求之效果檔)。

PS︰效果檔是以運算起迄期數︰524,526;輸入公式︰T5=1,T7=3產生。

另外︰

新的VBA檔的Sheet1~ Sheet7如果無作用的話,請予以刪除,

如果還有作用存在,就請以空白顯示即可。

以上

懇請各位大師與賢達不吝賜教!!!

謝謝!!!

1 Answer

Rating
  • 夏日
    Lv 5
    1 decade ago
    Favorite Answer

    Sub Macro1()

    Dim T_5%, T_7%, S_GO%, S_End%, i%, all$(7), arr, brr%(150, 2), crr

    Dim Rng As Range, j%, x%, p%, a%, b%, q%, Pages%, t!

    Application.Calculation = xlCalculationManual

    On Error GoTo ErrExit:

    T_5 = InputBox("T5公式序號?", 1)

    T_7 = InputBox("T7公式序號?", 1)

    Range("T5").FormulaArray = Sheets("Sheet8").Cells(T_5, 2).Formula

    Range("T7").Formula = Sheets("sheet8").Cells(T_7, 4).Formula

    Range("T7").Select

    SendKeys "{F2}", True

    SendKeys "^+{ENTER}", True

    S_GO = InputBox("請輸入運算起期", "輸入期數")

    S_End = InputBox("請輸入運算迄期", "輸入期數")

    On Error GoTo 0

    t = Timer

    Application.ScreenUpdating = False

    For i = 0 To 7

    all(i) = Sheets(i + 1).Name

    Next

    For i = S_GO To S_End

    Pages = 0

    arr = Range("A7").Resize(i + 2, 8)

    Sheets(all).Copy

    For j = 1 To 7

    Sheets(all(j - 1)).Select

    x = ActiveSheet.UsedRange.Rows.Count

    Range("7:7").Offset(i + 2).Resize(x - i + 1).Delete

    [Q:S].ClearContents

    [T:IV].Clear

    [s3] = i - 2: [Q6] = i - 1: [R6] = i: [S6] = i + 1

    [Q5] = arr(i, j + 1): [R5] = arr(i + 1, j + 1): [S5] = arr(i - 1, j + 1)

    [Q4] = arr(i, 8): [R4] = arr(i + 1, 8): [S4] = arr(i - 1, 8)

    p = -1

    For a = 2 To UBound(arr) - 1

    For b = 2 To UBound(arr, 2)

    If arr(a, b) = arr(i + 1, j + 1) Then

    p = p + 1

    brr(p, 0) = arr(a - 1, b)

    brr(p, 1) = arr(a, 1)

    brr(p, 2) = arr(a + 1, b)

    End If

    Next

    Next

    Range("Q7").Resize(p + 1, 3) = brr

    Sheets("DATA").Range("T5").Copy

    Range("T5").Resize(1, p + 1).PasteSpecial xlPasteFormulas

    ActiveSheet.Calculate

    Range("T5").Resize(1, p + 1).Copy

    Range("T5").Resize(1, p + 1).PasteSpecial xlPasteValues

    crr = Range("T3", Cells(6, [IV5].End(xlToLeft).Column))

    q = 0

    For a = 1 To UBound(crr, 2)

    For b = a To UBound(brr) + 1

    If crr(3, a) = brr(b - 1, 1) Then

    crr(1, a) = i + 1 - crr(3, a)

    crr(2, a) = brr(b - 1, 0)

    crr(4, a) = brr(b - 1, 2)

    q = q + 1

    Exit For

    End If

    Next

    Next

    Range("T3").Resize(4, p + 1) = crr

    Sheets("DATA").Range("T7").Copy

    Range("T7").Resize(p, q).PasteSpecial xlPasteFormulas

    ActiveSheet.Calculate

    If Application.Count(Range("T7").Resize(p, q)) > 0 Then

    Range("T7").Resize(p, q).Copy

    2009-07-18 23:01:11 補充:

    Range("T7").Resize(p, q).PasteSpecial xlPasteValues

    Range("T1").Resize(1, q) = "=IF(COUNT(R[6]C:R[" & p + 6 & "]C),"""",1/0)"

    ActiveSheet.Calculate

    Range("T1").Resize(1, q).SpecialCells(xlCellTypeFormulas, 16).EntireColumn.Delete

    2009-07-18 23:01:29 補充:

    Sheets("DATA").Range("U:U").Copy

    x = ActiveSheet.UsedRange.Columns.Count - 19

    Range("T:T").Resize(, x).PasteSpecial xlPasteFormats

    With Range("T1").Resize(2, x)

    .Value = ""

    .NumberFormatLocal = ""

    2009-07-18 23:01:42 補充:

    .Rows(1).Interior.ColorIndex = 8

    .Rows(1).Value = 1

    .Font.Bold = True

    .Font.ColorIndex = 7

    .Rows(1).Font.ColorIndex = 11

    For Each Rng In .Rows(6).Cells

    For a = 1 To 7

    If Rng.Value = arr(i + 2, a + 1) Then

    2009-07-18 23:01:53 補充:

    Rng.Offset(-4) = a

    Rng.Offset(-5) = Rng.Offset(-5).Value & "0"

    Rng.Offset(-5).Interior.ColorIndex = 6

    ActiveSheet.Tab.ColorIndex = 3

    End If

    Next

    Next

    End With

    Application.Goto Range("A1"), True

    Pages = Pages + 1

    Else

    2009-07-18 23:02:02 補充:

    Application.DisplayAlerts = False

    Sheets(all(j - 1)).Delete

    Application.DisplayAlerts = False

    End If

    Next

    If Pages = 0 Then

    ActiveWorkbook.Close , False

    Else

    Application.DisplayAlerts = False

    Sheets("DATA").Delete

    2009-07-18 23:02:17 補充:

    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\TEST_S_" & T_5 & "-" & T_7 & "-" & i & "期.xls"

    ActiveWorkbook.Close

    Application.DisplayAlerts = False

    End If

    Next

    [K1] = Format(Timer - t, "0秒")

    2009-07-18 23:02:25 補充:

    Application.ScreenUpdating = True

    Exit Sub

    ErrExit:

    MsgBox "對話方塊參數錯誤", vbInformation, "提示"

    End Sub

    2009-07-18 23:04:33 補充:

    就這樣子了。自己貼上答案不附檔了。

Still have questions? Get your answers by asking now.