Board logo

標題: 資料轉寫 [打印本頁]
作者: man65boy    時間: 2012-4-27 07:22     標題: 資料轉寫

如何以選擇特定資料，按鈕在轉寫，麻煩各位老師們不另指教!
附檔:
作者: GBKEE    時間: 2012-4-27 09:28

回復 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    時間: 2012-4-27 09:35

回復 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    時間: 2012-4-27 22:10

回復 3# register313


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

本帖最後由 GBKEE 於 2012-4-29 15:52 編輯

回復 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
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)