返回列表 上一主題 發帖

關於寫巨集程式自動篩選判斷區的代碼複製成該代碼單獨活頁簿

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
1# 跳轉到 »
發表於 2016-2-19 16:05 | 顯示全部帖子
試試看:
  1. '請貼到 "彙總表"
  2. Sub 彙入總表()
  3.     Dim sh1 As Worksheet, sh2 As Worksheet
  4.     Dim Lst1 As Integer, Lst2 As Integer
  5.     Dim I As Integer, J As Integer
  6.     Set sh1 = Sheets("彙總表")
  7.     For J = 1 To Sheets.Count
  8.         If Sheets(J).Name <> "彙總表" Then
  9.             Set sh2 = Sheets(J)
  10.             Lst1 = sh1.[B65536].End(xlUp).Row
  11.             Lst2 = sh2.[B65536].End(xlUp).Row
  12.             For I = 5 To Lst2
  13.                 sh2.Cells(I, 2).Resize(1, 4).Copy sh1.Cells(Lst1 + I - 4, 2)
  14.             Next
  15.         End If
  16.     Next
  17. End Sub
複製代碼

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
2#
發表於 2016-2-19 17:37 | 顯示全部帖子
回復 3# 學到老死
以下操作係以 2003為例               
你的版本請自行參考：               
1. 按 Alt+F11       
2. Double Click sheet("彙總表")       
3. 貼上 VBA Code       
4. 點巨集 Sub()…end       
5. 按 F5       
test.gif

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
3#
發表於 2016-2-19 19:39 | 顯示全部帖子
回復 5# 學到老死
'彙出到分頁
'先決條件:"彙總表"欄B中的sheets必須存在
Sub 彙出到分頁()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim Lst1 As Integer, Lst2 As Integer
    Dim I As Integer, J As Integer, shName As String
    Set sh1 = Sheets("彙總表")
    Lst1 = sh1.[B65536].End(xlUp).Row
    For I = 5 To Lst1
        shName = sh1.Cells(I, 2)
        For J = 1 To Sheets.Count
            If Sheets(J).Name = shName Then
                Lst2 = Sheets(J).[B65536].End(xlUp).Row + 1
                If Lst2 < 5 Then Lst2 = 5
                sh1.Cells(I, 2).Resize(1, 4).Copy Sheets(J).Cells(Lst2, 2)
                Exit For
            End If
        Next
    Next
End Sub

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
4#
發表於 2016-2-20 09:25 | 顯示全部帖子
本帖最後由 yen956 於 2016-2-20 09:26 編輯

回復 7# c_c_lai
謝謝c大的指導!!
改用c大的 UsedRange 可批次貼上, 果然簡捷多了, 謝謝指正!!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
5#
發表於 2016-2-20 11:10 | 顯示全部帖子
'若資料龐大, 彙出資料到分頁, 可改用本VBA, 會快很多
'先決條件:"彙總表"欄B中的工作表名稱的sheets必須存在
'且已按工作表名稱排序
Sub 彙出到分頁2()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shNameCnt As Integer
    Dim I As Integer
    Set sh1 = Sheets("彙總表")
    Lst1 = sh1.[B65536].End(xlUp).Row
    I = 5
    Do
        shName = sh1.Cells(I, 2)
        sh1.[C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])"   '計算同名的工作表有幾個
        sh1.Cells(I, 2).Resize(sh1.[C3], 4).Copy Sheets(shName).[B5]     '批次複製
        I = I + sh1.[C3]
    Loop Until I > Lst1
End Sub

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
6#
發表於 2016-2-21 13:40 | 顯示全部帖子
'借用 c大 的概念, 新增分頁, 這樣較有彈性
'請貼到 "彙總表"
'彙出到分頁3
'判判分頁是否存在
Function shExist(ByVal shName As String) As Boolean
    Dim I As Integer
    shExist = False
    For I = 1 To Sheets.Count
        If Sheets(I).Name = shName Then
            shExist = True
            Exit Function
        End If
    Next
End Function

Sub 彙出到分頁3()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shNameCnt As Integer
    Dim I As Integer, J As Integer
   
    '********************
    '清除分頁內容, 如有其他重要分頁, 如"統計"等, 兩列*****間, 請註解掉或刪掉
    For J = 1 To Sheets.Count
        If Sheets(J).Name <> "彙總表" Then Sheets(J).Cells.Clear
    Next
    '**************
   
    '加入原序號, 方便恢復原狀(暫放欄A,可改放別欄)
    Lst1 = [B65536].End(xlUp).Row
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '按工作表名稱排序
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    For I = 5 To Lst1
        shName = Cells(I, 2)
        
        '判判分頁是否存在, 如不存在則新增一頁
        If Not shExist(shName) Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        [C4:E4].Copy Sheets(shName).[C4]     '複製標題
        [C3].FormulaR1C1 = "=COUNTIF(C[-1],""=""&R" & I & "C[-1])"   '計算同名的工作表有幾個
        Cells(I, 2).Resize([C3], 4).Copy Sheets(shName).[B5]         '批次複製
        I = I + [C3] - 1
    Next
   
    '恢復原狀, 按原序號排序, 並清除暫存區
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear: [C3].Clear    '欄A 及 [C3] 均為暫存區
End Sub

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
7#
發表於 2016-2-22 10:22 | 顯示全部帖子
回復 13# 准提部林
准大你好!!
又學到一招, 直接
    Set Sht = Nothing
    If T = "" Or InStr(TT & "/", "/" & T & "/") Then GoTo 101
    On Error Resume Next
    Set Sht = Sheets(T)
    On Error GoTo 0
    If Sht Is Nothing Then
        Set Sht = Sheets.Add(After:=Sheets(Sheets.Count))
    End If
就可以不必先判斷sht是否存在,真高, 收下, 謝謝!!
但請問 InStr(TT & "/", "/" & T & "/")  的作用是什麼?謝謝!!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
8#
發表於 2016-2-22 12:30 | 顯示全部帖子
回復 16# 准提部林
回復 lpk187:
回復 准大:
謝謝兩位詳細的說明, 謝謝!!

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
9#
發表於 2016-2-22 15:48 | 顯示全部帖子
'彙出到分頁4(純自我學習 VBA 用, 別無它意):
'更新版, 更新重點如下:
'1. 既然 欄A及[C3] 均為暫存區, 則應整合到同一欄中, 故[C3]應改到[A3]
'2. 兩列*****間的 清除分頁 應移 "主程式" 式內, 可避免誤刪重要資料
'3. 改用准大的概念, 不另判別分頁是否存在, 即刪除 Function shExist, 可省掉不少迴圈
'
'更正結果如下:
'請貼到 "彙總表"

Sub 彙出到分頁4()
    Dim sh1 As Worksheet
    Dim Lst1 As Integer, shName As String
    Dim i As Integer, J As Integer
    Lst1 = [B65536].End(xlUp).Row
   
    '加入原序號, 方便恢復原狀(暫放欄A,可改放別欄)
    [A5] = 1: Range("A5:A" & Lst1).DataSeries
   
    '按工作表名稱排序
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[B5], Order1:=xlAscending, Header:=xlNo
   
    '主程式
    For i = 5 To Lst1
        shName = Cells(i, 2)
        
        Set sh1 = Nothing
        On Error Resume Next
        Set sh1 = Sheets(shName)
        On Error GoTo 0
        
        '若 sh1 仍為 Nothing → 名為 shName 的工作表並不存在 → 增加新工作表
        If sh1 Is Nothing Then
            Set sh1 = Sheets.Add(After:=Sheets(Sheets.Count))
            sh1.Name = shName
        End If
        
        sh1.Cells.Clear           '清除分頁
        [B4:E4].Copy sh1.[B4]     '複製標題
        [A3].FormulaR1C1 = "=COUNTIF(C[1],""=""&R" & i & "C[1])"   '計算同名的工作表有幾個
        Cells(i, 2).Resize([A3], 4).Copy sh1.[B5]                  '批次複製同名的工作表
        i = i + [A3] - 1                '跳到下個不同名工作表, 故不用篩選
    Next
   
    '恢復原狀 → 按原序號排, 並清除暫存區
    [A5].Resize(Lst1 - 5, 5).Sort Key1:=[A5], Order1:=xlAscending, Header:=xlNo
    [A:A].Clear     '清除暫存區 欄A
End Sub

TOP

        靜思自在 : 看別人不順眼，是自己修養不夠。
返回列表 上一主題