Airman
Lv 4
Airman asked in 電腦與網際網路軟體 · 1 decade ago

EXCEL~VBA~請依據新需求修改程式碼。謝謝!!!

MS 2003版

如題~

範例附檔︰http://www.FunP.Net/125702

原效果檔詳如︰TEST_V_2_524 ,TEST_V_2_525,TEST_V_2_526。

現想將效果檔改為~

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

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

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

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

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

詳如︰

TEST_V_2_524(新需求之效果檔)& TEST_V_2_526(新需求之效果檔);

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

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

另外︰

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

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

以上

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

謝謝!!!

3 Answers

Rating
  • 1 decade ago
    Favorite Answer

    圖片參考:http://l.yimg.com/f/i/tw/ugc/rte/smiley_4.gif

    此段程式碼變更如下

    goend:

    [A1].Select

    ' Sheets("Data").Activate

    ' Sheets("DATA").[T5].Select

    ' Selection.Copy

    ' Sheets(s).Select

    ' Range(Cells(5, 20), Cells(5, Range("T5").End(xlToRight).Column)).Select

    ' Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone

    ' Application.ScreenUpdating = True

    ' Calculate

    ' Application.ScreenUpdating = False

    ' Range(Cells(5, 20), Cells(5, Range("T5").End(xlToRight).Column)).Select

    ' Selection.Copy

    ' Selection.PasteSpecial Paste:=xlPasteValues

    ' Range("T5:IV5").Select

    ' Selection.Copy

    ' Selection.PasteSpecial Paste:=xlPasteValues

    Sheets(s).Select

    For ST5 = 7 To Sheets(s).[R65536].End(xlUp).Row

    Sheets(s).Cells(5, ST5 + 13) = Sheets(s).Cells(ST5, 18)

    Next ST5

    存檔部分

    Sheets("DATA").Select

    [A1].Select

    ThisPath = ThisWorkbook.Path & "\"

    Sheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7")).Copy

    ActiveSheet.DrawingObjects.Delete

    Application.DisplayAlerts = False

    ChDir ThisPath

    savename = ThisPath & "TEST_A_" & mthcount & ".xls"

    ' ActiveWorkbook.SaveAs Filename:=savename

    On Error GoTo errext

    For tsht = 7 To 1 Step -1

    shtr = Sheets(tsht).[R65536].End(xlUp).Row

    If WorksheetFunction.Count(Range(Sheets(tsht).Cells(7, 20), Sheets(tsht).Cells(shtr, 20 + shtr))) = 0 Then

    Sheets(tsht).Delete

    Else

    Sheets(tsht).Select

    shtr = Sheets(tsht).[R65536].End(xlUp).Row

    For col = 20 + shtr To 20 Step -1

    If WorksheetFunction.Count(Range(Sheets(tsht).Cells(7, col), Sheets(tsht).Cells(shtr, col))) = 0 Then

    Columns(col).Delete

    End If

    Next col

    End If

    Next

    請參考附件下載

    http://www.FunP.Net/683044

  • Airman
    Lv 4
    1 decade ago

    阿玲姐:

    甭客氣!!

    有空請常來店裡喝茶,

    交換彼此的心得也是美事一樁~

    ^^

    謝謝您的點數贊助。

  • 阿玲
    Lv 4
    1 decade ago

    Air man~求知者:

    感謝大大提供的Idea~

    ^^

    贊助先~

Still have questions? Get your answers by asking now.