如何讓Sheet2=I3，然後又讓該檔名可以繼續變更? - Excel程式區

[發問] 如何讓Sheet2=I3，然後又讓該檔名可以繼續變更?

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2012-10-15 18:05 | 顯示全部帖子

本帖最後由 GBKEE 於 2012-10-16 10:59 編輯

回復 3# av8d
是這樣嗎?

Option Explicit
Sub Ex()
Dim Car_No As String, xlRow As Long
With Sheet1
.Activate
.AutoFilterMode = False
Car_No = InputBox("請輸入車號")
If Car_No = "" Then MsgBox "沒輸入車號 ??" & Car_No: Exit Sub
.Rows(2).Cells(1).AutoFilter Field:=9, Criteria1:=UCase(Car_No)
xlRow = .Rows(2).Cells(9).End(xlDown).Row
If xlRow <> Rows.Count Then
.Cells.SpecialCells(xlCellTypeVisible).Copy
Else
MsgBox "找不到車號 !! " & Car_No: Exit Sub
End If
With Sheets.Add(, Sheets("sheet1"))
.Paste
Application.CutCopyMode = False
.Name = .[i3]
.[a1].Select
End With
'.Rows(xlRow).Delete '刪一行資料
'http://forum.twbts.com/viewthread.php?tid=6706&rpid=45209&ordertype=0&page=7#pid45209
'提醒修改刪多行資料
.Cells.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Offset(2).Delete xlUp
.AutoFilterMode = False
.Activate
End With
End Sub

複製代碼

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2012-10-16 13:23 | 顯示全部帖子

回復 5# av8d

Dim d As Object
Private Sub UserForm_Initialize()
Dim A As Range
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
.Activate
For Each A In .Range("I3", .[i3].End(xlDown))
d(A.Value) = IIf(d(A.Value) = "", A.Offset(, 1).Value, d(A.Value) & "," & A.Offset(, 1))
Next
ComboBox1.List = d.keys
End With
車號工作表數
End Sub
Private Sub ComboBox1_Change() ' 復原篩選
ActiveSheet.AutoFilterMode = False
End Sub
Private Sub CommandButton1_Click() ' 復原篩選
ctiveSheet.AutoFilterMode = False
End Sub
Private Sub CommandButton2_Click()
Call Ex
車號工作表數
End Sub
Private Sub 車號工作表數()
TextBox1 = Sheets.Count - 1
End Sub

複製代碼

Option Explicit
Sub Ex()
Dim Car_No As String, xlRow As Long, E As Range, Rng As Range
With Sheet1
.Activate
.AutoFilterMode = False
Car_No = UserForm1.ComboBox1
.Rows(2).Cells(1).AutoFilter Field:=9, Criteria1:=UCase(Car_No)
xlRow = .Rows(2).Cells(9).End(xlDown).Row
If xlRow <> Rows.Count Then
Set Rng = .Cells.SpecialCells(xlCellTypeVisible)
Else
MsgBox "找不到車號 !! " & Car_No: Exit Sub
End If
'**********
On Error Resume Next '啟動的錯誤處理程式: 有錯誤繼續下一行程式碼
Sheets(Car_No).Activate '沒有車號工作表會有錯誤
If Err.Number <> 0 Then '程式有錯誤
Sheets.Add , Sheets("sheet1") '新增工作表
'***消除有錯誤繼續下一行程式碼的指令***
On Error GoTo 0 '停止現在程序裏任何已啟動的錯誤處理程式。
End If
'**********************
With ActiveSheet
.Cells.Clear
Rng.Copy .[a1]
Application.CutCopyMode = False
.Name = .[i3]
.Cells(.Rows.Count, "O").End(xlUp).Offset(1, -1) = "合計"
.Cells(.Rows.Count, "O").End(xlUp).Offset(1) = Application.Sum(.Range("O:O")) '金額加總
End With
'--*** 是否可以不移除或移除3筆---
If UserForm1.OptionButton1 Then '***表單新增 OptionButton1 控制項 .Value=True
For Each E In Rng.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).EntireRow
If E.Row > 2 Then E.Delete
Next
End If
'-- ****************
.AutoFilterMode = False
.Activate
End With
End Sub

複製代碼

回復 6# c_c_lai
.Cells.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants).Offset(2).Delete xlUp
是有錯誤的已修正試試看

靜思自在 : 屋寬不如心寬。