資料轉寫

man65boy

如何以選擇特定資料，按鈕在轉寫，麻煩各位老師們不另指教!
附檔:

GBKEE

回復 1# man65boy

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim A As Range, R As Range, Rng As Range
   
4.     With Sheet1
   
5.         .AutoFilterMode = False                         ' 取消[自動篩選]
   
6.         .Range("a1").AutoFilter 5, "自取"               '[自動篩選] 設定第5欄的篩選準則 = "自取"
   
7.         With .UsedRange.SpecialCells(xlCellTypeVisible) '自動篩選後的資料
   
8.             .Copy Sheet2.[A1]                           '複製資料
   
9.             For Each A In .Areas                        'Areas 屬性: 此集合代表多重範圍中的所有範圍。唯讀
   
10.                 For Each R In .Rows                     '範圍 的整列
    
11.                     If R.Row <> 1 Then                  '列號不是欄位的 列號
    
12.                         If Rng Is Nothing Then
    
13.                             Set Rng = R
    
14.                         Else
    
15.                             Set Rng = Union(Rng, R)     'Union 方法  定傳回兩個或多個範圍的合併範圍
    
16.                         End If
    
17.                     End If
    
18.                 Next
    
19.             Next
    
20.         End With
    
21.         .AutoFilterMode = False                         ' 取消[自動篩選]
    
22.         If Not Rng Is Nothing Then                  '自動篩選 有資料
    
23.             Application.DisplayAlerts = False       'DisplayAlerts 屬性  Microsoft Excel 顯示特定的警告和訊息則為 True。讀/寫 Boolean。
    
24.             Rng.Delete                              '刪除 自動篩選後的資料
    
25.             Application.DisplayAlerts = True
    
26.         Else                                        '自動篩選 沒有資料
    
27.             MsgBox "查烏資料"
    
28.         End If
    
29.     End With
    
30. End Sub

複製代碼

register313

回復 1# man65boy

1. Sub xx()
   
2. Dim Rng As Range, A As Range
   
3. Sheet1.[A1:E1].Copy Sheet2.[A1]
   
4. With Sheet1
   
5.   For Each A In .Range(.[A2], .[A2].End(xlDown))
   
6.     If A.Offset(0, 4) = "自取" Then
   
7.       If Rng Is Nothing Then
   
8.          Set Rng = A.Resize(1, 5)
   
9.       Else
   
10.          Set Rng = Union(Rng, A.Resize(1, 5))
    
11.       End If
    
12.     End If
    
13.   Next
    
14.   If Not Rng Is Nothing Then
    
15.      Rng.Copy Sheet2.[A65536].End(xlUp).Offset(1, 0)
    
16.      Rng.EntireRow.Delete
    
17.   End If
    
18. End With
    
19. End Sub

複製代碼

man65boy

回復 3# register313


    感謝2位熱心版主的回答，GBKEE老師的程式提供了，我這種初學者易懂的程式，但程式執行轉寫到sheet2時，並無法往下排列，稍點不足，不過還謝謝GBKEE老師，
    感謝register313老師，提供完全解題百分百，感恩在心!小弟也要花點時間來消化2位老師的程式，謝謝。

GBKEE

回復 4# man65boy
並無法往下排列，稍點不足   修正了

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim A As Range, R As Range, Rng As Range
   
4.     With Sheet1
   
5.         .AutoFilterMode = False                         ' 取消[自動篩選]
   
6.        .Range("a1").AutoFilter 5, "自取"               '[自動篩選] 設定第5欄的篩選準則 = "自取"
   
7.         Sheet2.Rows(1) = .Rows(1).Value
   
8.         Set Rng = .Range("a1").CurrentRegion.Offset(1)
   
9.         On Error Resume Next
   
10.         Set Rng = Rng.SpecialCells(xlCellTypeVisible)        '自動篩選後的資料
    
11.          If Err.Number > 0 Then                              '沒有資料有錯誤
    
12.             MsgBox "查無資料"
    
13.          Else
    
14.             Rng.Copy Sheet2.Cells(Rows.Count, "a").End(xlUp).Offset(1)             '改在這裡複製
    
15.             Rng.Delete xlShiftUp                              '刪除 自動篩選後的資料
    
16.           End If
    
17.         .AutoFilterMode = False                         ' 取消[自動篩選]
    
18.     End With
    
19. End Sub

複製代碼