register313

回復 5# tonycho33

超版,版主大概是沒有作不出來的問題
重點是希望發問者:
1.事先作好功課,把希望的功能描述清楚,不要反反覆覆,改來改去(幾次後真的沒人想幫)
2.附上EXCEL檔案,數據應把所有可能的情形都考慮進來


SHEET B之K欄不可有資料
同一工單若有的完成,有的未完成有時會分開顯示(應可接受吧)

1. Sub Ex()                       '1.將A SHEET存到B SHEET 當J欄有出現任何值
   
2.     Dim xText As String
   
3.     xText = "<>"
   
4.     Data_Copy 10, xText
   
5. End Sub
   
6. Sub ExA()                      '2.按下按鈕時(對應工單號碼),該工單對應的所有列就複製到B SHEET空白處
   
7.     Dim xText As String
   
8.     xText = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text
   
9.     Data_Copy 1, xText
   
10. End Sub
    
11. Private Sub Data_Copy(xF As Integer, xCriteria As String)
    
12.     Dim Sh As Worksheet
    
13.     Application.ScreenUpdating = False
    
14.     Application.DisplayAlerts = False
    
15.     With Sheet7   'Sheets("A")
    
16.         .AutoFilterMode = False
    
17.         .Range("a1").AutoFilter Field:=xF, Criteria1:=xCriteria
    
18.          Set Sh = Sheets.Add
    
19.         .UsedRange.SpecialCells(xlCellTypeVisible).Copy Sh.[a1]
    
20.          Sh.UsedRange.Offset(1).Copy Sheet6.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
21.         'Sheet6->Sheet("B")
    
22.          Sh.Delete
    
23.         .AutoFilterMode = False
    
24.         .Activate
    
25.     End With
    
26.     Call deleterow                       '刪除B工作表之重覆列
    
27.     Application.ScreenUpdating = True
    
28.     Application.DisplayAlerts = True
    
29. End Sub
    
30. Sub deleterow()                          '刪除B工作表之重覆列
    
31.     With Sheet6
    
32.       R = .[A65536].End(xlUp).Row
    
33.       For RM = 2 To R
    
34.         For MM = 1 To 9                  'SHEET B之K欄不可有資料
    
35.             .Cells(RM, 11) = .Cells(RM, 11) & .Cells(RM, MM)
    
36.         Next MM
    
37.       Next RM
    
38.       For I = 2 To R Step 1
    
39.         If (WorksheetFunction.CountIf(.Columns(11), .Cells(I, 11)) > 1) Then
    
40.            .Rows(I).Delete
    
41.            I = I - 1
    
42.         End If
    
43.       Next
    
44.       .Columns(11) = ""
    
45.     End With
    
46. End Sub

複製代碼

Book1111.rar (48.49 KB)

下載次數: 6

2012-2-15 11:07

register313

回復 10# tonycho33

1. Sub QQ()
   
2. BR = 2
   
3. With Sheets("aa")
   
4.   For AR = 3 To [A65536].End(xlUp).Row Step 3
   
5.     If .Cells(AR, "T") = "已排程" Then
   
6.        .Cells(AR, "A").Resize(3, 19).Copy Sheets("bb").Cells(BR, "A")
   
7.        BR = BR + 3
   
8.     End If
   
9.   Next AR
   
10. End With
    
11. End Sub

複製代碼

register313

回復 13# tonycho33

    a按鈕(aa->bb)拿掉 b按鈕(bb->cc)拿掉  (不能自己用按鈕控制)
=> 當aa工作表T欄新增1個"已排程"時,自動新增到bb工作表及cc工作表
   
Book1.rar (29.93 KB)

下載次數: 13

2012-2-16 18:04