Board logo

標題: 請問如何將資料"剪下"然後向中間的空格向上貼齊呢? [打印本頁]
作者: vpower    時間: 2010-7-22 23:14     標題: 請問如何將資料"剪下"然後向中間的空格向上貼齊呢?

提示: 作者帳號被禁止或禁止訪問
作者: kimbal    時間: 2010-7-22 23:35

本帖最後由 kimbal 於 2010-7-23 00:13 編輯

問題一: (這個是用刪除吧)
  1. on error resume next
  2. ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
複製代碼
問題二:
如hsieh大下面所說,如果沒有層疊關係, 以下可找出運行時是空百的然後刪除
  1.     Dim r, rs
  2.     Dim allR As Range
  3.    
  4.     With ActiveSheet.UsedRange
  5.         Set r = .Find("", LookIn:=xlValues)
  6.         Set rs = r
  7.         If Not r Is Nothing Then
  8.            Set allR = r
  9.             Do
  10.                 Set allR = Union(allR, r)
  11.                 Set r = .FindNext(r)
  12.             Loop While Not r.Address = rs.Address
  13.         End If
  14.         If Not allR Is Nothing Then
  15.             allR.Delete Shift:=xlUp
  16.         End If
  17.     End With
複製代碼
作者: Hsieh    時間: 2010-7-22 23:55

回復 1# vpower


    問題2若用複製/選擇性貼上/值
再刪除空格可行嗎?
作者: luhpro    時間: 2010-7-23 00:29

或許也可以採用先清除空白行內的公式, (因為用不到)
再利用 Range的Copy函數依序將公式搬移上來.
這裡請恕不再列出如何找空白行的公式.

With Worksheets("Sheet3")
  .Range("A2:J3").Clear
  .Range("A5:J6").Clear
  .Range("A8:J9").Clear

  .Range("A4:J4").Copy _
      Destination:=.Range("A2")
  .Range("A4:J4").Clear


  .Range("A7:J7").Copy _
      Destination:=.Range("A3")
  .Range("A7:J7").Clear

  .Range("A10:J10").Copy _
      Destination:=.Range("A4")
  .Range("A10:J10").Clear

End With
作者: Hsieh    時間: 2010-7-23 08:17

回復 4# luhpro
樓主說明是此例較規則所以整列刪除並不影響
若這些公式得到非空值時刪除公式就不對了
作者: vpower    時間: 2010-7-23 14:25

提示: 作者帳號被禁止或禁止訪問
作者: luhpro    時間: 2010-7-26 00:11

本帖最後由 luhpro 於 2010-7-26 00:14 編輯

回復 6# vpower

如果只是單純的要將資料放在一起,
我之前有想到一種方法可以達成.
(因為之前用的方式就不是用公式做的, 所以先提供給你應急用, 至於用公式來達成的方式就煩請其他人提供給你囉)

就是先在某欄最上方訂定一個基數(0 或 1000 皆可),
C1 = 1000
然後利用公式將有資料的那一列依序編號,
C2 = IF(A1="",IF(C1<1000,C1+1000,C1),IF(C1<1000,C1+1,C1-1000+1))
C3 以後直接 下拉即可,(範例中下拉到 C501, 因為 C1並未對應到資料的第一列)
最後再一一抓出來顯示資料即可,
D1 = IF(ROW()>$F$1,"",INDIRECT(CONCATENATE("A",MATCH(ROW(),$C$1C$501,0)-1)))
E1 = IF(ROW()>$F$1,"",INDIRECT(CONCATENATE("B",MATCH(ROW(),$C$1C$501,0)-1)))
D2 與 E2 以後亦直皆下拉即可,,(範例中下拉到 D500, 因為 D1有對應到資料的第一列)

至於要怎樣使用抓出來的資料那就要看你的需求囉.
[attach]1979[/attach]
作者: vpower    時間: 2010-7-26 21:29

提示: 作者帳號被禁止或禁止訪問
作者: luhpro    時間: 2010-7-27 00:17

本帖最後由 luhpro 於 2010-7-27 00:21 編輯

我剛剛想到可以用公式套用我在第 7 篇上所使用的方法,
就是用程式在 "原稿" 的 NOPQRST 等欄分別列出各級學校名稱如 "托兒所"、"小學"...等依次的關鍵字,
再於各欄將每筆資料抓出來依序給予編號,
以上程式如下:

Sub Main()
  Dim iCount As Integer, iCol As Integer, iFrow As Integer, iRow As Integer
  Dim iI As Integer, iJ As Integer
  Dim rC As Range

  With Sheets("原稿")
    With .Range("a1:m1")
      Set rC = .Find("學校", LookIn:=xlValues)
      If Not rC Is Nothing Then
        iCol = rC.Column
      End If
    End With
    iCount = .Cells(Rows.Count, iCol).End(xlUp).Row()

    .Range(Cells(2, 14), Cells(iCount, 20)).Clear

    For iI = 1 To 7
      With .Range(Cells(1, iCol), Cells(iCount, iCol))
        Set rC = .Find(Cells(1, 13 + iI), LookIn:=xlValues)
        If Not rC Is Nothing Then
          iJ = 0
          iFrow = rC.Row
          Do
            iJ = iJ + 1
            iRow = rC.Row
            Cells(iRow, 13 + iI) = iJ
            Set rC = .FindNext(rC)
          Loop While Not rC Is Nothing And rC.Row <> iFrow
        End If
      End With
    Next iI
  End With
End Sub

[attach]2003[/attach]

如此甚至整個 "分類" Sheet 的內容與文字格式等都可以用程式直接產生出來. (只要沒刪到第一列的欄位名稱,應該都不受原稿編修的影響)
因為時間晚了來不及繼續下去這部份就要請你自己做或等我晚上有時間才能做囉.
作者: vpower    時間: 2010-7-27 19:23

提示: 作者帳號被禁止或禁止訪問



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