Airman
Lv 4

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

MS 2003版

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產生。

Rating

此段程式碼變更如下

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

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

阿玲姐:

甭客氣!!

有空請常來店裡喝茶，

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

^^

謝謝您的點數贊助。

• 阿玲
Lv 4

Air man~求知者:

感謝大大提供的Idea~

^^

贊助先~