| |
キタ さん,ぴかるさんこんばんは。
とりあえず、力不足かもしれませんが、なんとなくコードを書いてみました。
仮定に仮定を重ねた怪しげなものですが。
Sub Sample()
Dim AACD&, BBCD&, NewRecCnt&
Dim i&, ARecCnt&, BRecCnt&, TempRecCnt&
'AACD、BBCDをきちんと設定しないと動きません。仮定で A列、B列をしておきます。
AACD& = 1: BBCD = 2
'シートCが空白だと仮定
NewRecCnt& = 2
Application.ScreenUpdating = False
'A列最終行までデータが入っていると仮定
ARecCnt& = Sheets("A").Cells(65536, 1).End(xlUp).Row
BRecCnt& = Sheets("B").Cells(65536, 1).End(xlUp).Row
'1行目はタイトル行と仮定。
Sheets("A").Rows(1).Copy Destination:=Sheets("C").Rows(1) 'シートCにタイトル行を追加
For i& = 2 To ARecCnt&
With Sheets("A")
If .Cells(i&, AACD).Value = 1 And .Cells(i&, BBCD).Value = 2 Then
.Rows(i&).Copy Destination:=Sheets("C").Rows(NewRecCnt&)
NewRecCnt = NewRecCnt + 1
End If
End With
Next i&
TempRecCnt = NewRecCnt
On Error Resume Next 'ソートに関する細かい設定は 『Sort』でHELPをご参照ください。
Sheets("C").Rows("2:" & TempRecCnt& - 1).Sort Key1:=Range("K2")
On Error GoTo 0
For i& = 2 To BRecCnt&
With Sheets("B")
If .Cells(i&, AACD).Value = 1 And .Cells(i&, BBCD).Value = 2 Then
.Rows(i&).Copy Destination:=Sheets("C").Rows(NewRecCnt&)
NewRecCnt& = NewRecCnt& + 1
End If
End With
Next i&
On Error Resume Next
Sheets("C").Rows(TempRecCnt& & ":" & NewRecCnt& - 1).Sort Key1:=Range("K" & TempRecCnt&)
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
|
|
- 03/6/20(金) 19:50 -
