| |
▼うさこ さん：
コード案を２つほどアップします。
ご参考まで。（急いで書いたので結構、処理効率は悪いです。）
ほんとは、フィルタオプションが適していると思います。
もし、ご興味があれば、そのバージョンを書いてアップします。
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
|
|
UO3
- 12/8/13(月) 17:19 -
