Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9826 / 76734 ←次へ | 前へ→

【72465】Re:転記したい
発言  UO3  - 12/8/13(月) 17:19 -

引用なし
パスワード
   ▼うさこ さん:

コード案を2つほどアップします。
ご参考まで。(急いで書いたので結構、処理効率は悪いです。)
ほんとは、フィルタオプションが適していると思います。
もし、ご興味があれば、そのバージョンを書いてアップします。

Sub Sample1()  'オートフィルター
  Dim yy As Long
  Dim mm As Long
  
  Application.ScreenUpdating = False
  
  yy = 2012
  mm = 7

  With Sheets("Sheet1")
    .AutoFilterMode = False '設定されていればいったん解除
    .Range("A1").AutoFilter
    
    .AutoFilter.Range.AutoFilter Field:=1, _
      Criteria1:=">=" & CDbl(DateSerial(yy, mm, 1)), Criteria2:="<" & CDbl(DateSerial(yy, mm + 1, 1)), Operator:=xlAnd
  
    .UsedRange.Copy Sheets("Sheet2").Range("A1")
    .UsedRange.Copy Sheets("Sheet3").Range("A1")
    
    .AutoFilterMode = False
    
  End With
  
  Sheets("Sheet2").Columns("H:L").Delete
  Sheets("Sheet3").Columns("C:G").Delete
  
  Application.ScreenUpdating = True
  
End Sub

Sub Sample2()  'フィルターを使わない(上司の命令?)
  Dim v() As Variant
  Dim c As Range
  Dim k As Long
  Dim yy As Long
  Dim mm As Long
  Dim fdate As Date
  Dim tdate As Date
  
  Application.ScreenUpdating = False
  
  yy = 2012
  mm = 7

  fdate = DateSerial(yy, mm, 1)
  tdate = DateSerial(yy, mm + 1, 1)
  
  With Sheets("Sheet1")
    ReDim v(1 To .Rows.Count)
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      If c.Value >= fdate And c.Value < tdate Then
        k = k + 1
        v(k) = c.EntireRow.Range("A1:L1").Value
      End If
    Next
  End With
  
  ReDim Preserve v(1 To k)
  
  With Sheets("Sheet2")
    .Cells.ClearContents
    .Range("A1:L1").Value = Sheets("Sheet1").Range("A1:L1").Value
    .Range("A2").Resize(k, 12).Value = _
      WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
    .UsedRange.Copy Sheets("Sheet3").Range("A1")
  End With
  
  Sheets("Sheet2").Columns("H:L").Delete
  Sheets("Sheet3").Columns("C:G").Delete
  
  Application.ScreenUpdating = True
  
End Sub
4 hits

【72452】転記したい うさこ 12/8/13(月) 12:01 質問
【72454】Re:転記したい UO3 12/8/13(月) 14:08 発言
【72455】Re:転記したい うさこ 12/8/13(月) 14:13 質問
【72456】Re:転記したい UO3 12/8/13(月) 14:27 発言
【72457】Re:転記したい UO3 12/8/13(月) 14:29 発言
【72458】Re:転記したい うさこ 12/8/13(月) 14:57 質問
【72461】Re:転記したい うさこ 12/8/13(月) 16:36 質問
【72462】Re:転記したい Yuki 12/8/13(月) 16:51 発言
【72465】Re:転記したい UO3 12/8/13(月) 17:19 発言
【72467】Re:転記したい UO3 12/8/13(月) 17:36 発言
【72468】Re:転記したい kanabun 12/8/13(月) 17:50 発言
【72469】Re:転記したい うさこ 12/8/13(月) 18:31 お礼

9826 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free