| |
▼ののか さん：
>移動に変更したいです。
>元のシートに残らないようにＶＢＡを変更してほしいのですが・・・
フィルタで抽出した範囲を(Copyではなく)、Cut すればいいと思うが、
不連続行に対して Cut&Pasteはできないので、
作業列に「1」を全行書き込んでおいてから、
フィルタかけて抽出された行の作業列だけ「空白」に置き換えてから、
作業列でSortかけると、抽出行が元表の下方に集合するので、
作業列が空白の範囲（単一エリア）を Cutして「AA」シートに貼り付ける
ようにしました。
Sub AAデータの移動_AutoFilter()
Dim AAsheet As Worksheet
Dim ws As Worksheet
Dim fCount As Long
Dim cFrom As Range
Dim CopyTo As Range
Dim n As Long, m As Long
With ActiveWorkbook.Worksheets
On Error Resume Next
Set AAsheet = .Item("AA") '転記先シート
On Error GoTo 0
If AAsheet Is Nothing Then
If MsgBox("「AA」シートがありません。作成しますか？", _
vbOKCancel) = vbOK Then
Set AAsheet = .Add(After:=.Item(.Count))
AAsheet.Name = "AA"
Else
Exit Sub
End If
Else
AAsheet.UsedRange.ClearContents
End If
End With
For Each ws In ActiveWorkbook.Worksheets
If IsNumeric(ws.Name) Then
ws.AutoFilterMode = False
With ws.Cells(1).CurrentRegion
m = .Columns.Count
.Columns(m + 1).Value = 1 '作業列に1を書き込む
.AutoFilter 3, "AA"
n = .Columns(1).SpecialCells(xlVisible).Count
If n > 1 Then
fCount = fCount + 1
Set CopyTo = AAsheet.Cells(Rows.Count, 1).End(xlUp)
If fCount = 1 Then
.Rows(1).Copy CopyTo '項目行のコピー
End If
Set cFrom = Intersect(.Cells, .Offset(1))
cFrom.Columns(m + 1).ClearContents '可視行だけClear
.AutoFilter 'フィルタ解除して ↓作業列で並び替え
cFrom.Resize(, m + 1).Sort Key1:=cFrom.Columns(m + 1), _
Header:=xlNo
'作業列が空白の行だけ移動
cFrom.Resize(n - 1).Offset(.Rows.Count - n).Cut CopyTo(2)
Else
.AutoFilter
End If
.Columns(m + 1).Clear
End With
End If
Next
MsgBox "抽出転記しました", vbInformation
End Sub
最初のCopyの方法で、処理速度はどんな程度だったのですか？
次々要求を挙げるのでなく、コードを理解することが大切です。
分からないところがあったら、質問してください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
