|
エラー回避さん、Jaka さん、こんばんは。
>Range("B:B").Insert Shift:=xlToRight
>Range("A1").Value = Range("A2").Value
>Range("B2:B1109").Formula = "=EXACT(A1,A2)"
>range("B1").value = "XXXXX"
>Range("B1:B1109").AutoFilter Field:=2, Criteria1:="FALSE"
>Range("B2:B1109").SpecialCells(xlCellTypeVisible).Select
>ここから下がわからないので直してない。
>「'データ消失を防ぐ為エラーRangeクラスメゾネットエラー」
たぶん、行挿入してしまうと押し出されるデータがあったからではないですか?
セルA65536に1と指定して、適当な位置で行挿入を行うと上記のエラーが
出ますね?
まあ、それ以外にも
Selection.Insert Shift:=xlDown
このコードは問題がありそうですが・・・。
新規ブックの標準モジュールに
'=================================================================
Sub A行情報変わる位置行挿入2()
Dim rng As Range
Dim ans As Range
Dim idx As Long, jdx As Long
On Error Resume Next
Call サンプルデータ作成
MsgBox "A列にサンプルデータ作成"
Range("B:B").Insert Shift:=xlToRight
Set rng = Range("a2", Cells(Rows.Count, "a").End(xlUp))
If rng.Row > 1 Then
With rng
.Offset(0, 1).Formula = "=if(row()=" & rng.Row & ","""",if(EXACT(R[-1]C[-1],RC[-1]),"""",1))"
Set ans = .Resize(, 2).SpecialCells(xlCellTypeFormulas, xlNumbers)
If Err.Number = 0 Then
With ans.Areas
For idx = .Count To 1 Step -1
For jdx = .Item(idx).Count To 1 Step -1
.Item(idx).Cells(jdx).EntireRow.Insert xlDown
Next
Next
End With
End If
End With
Range("B:B").Delete
End If
End Sub
'====================================================================
Sub サンプルデータ作成()
Dim idx As Long, jdx As Long
Dim smpArray As Variant
Dim kdx As Long
Range("a:a").Value = ""
kdx = 2
smpArray = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", _
"k", "l", "m", "n", "o", "p", "q", "r", "s", "t")
For idx = 1 To 20
num = Int(Rnd() * 8) + 1
For jdx = kdx To kdx + num - 1
Cells(jdx, 1).Value = smpArray(idx - 1)
Next jdx
kdx = kdx + num
Next idx
End Sub
上記のコードをコピーしてください。
何も入力されていないシートをアクティブにして
「A行情報変わる位置行挿入2」を実行してみてください。
結果としてこのコードが示すような出力がご希望の出力でしょうか?
A列の2行目から
A
1
2 a
3 a
4 a
5 b
6 b
7 b
8 b
9 c
10 c
11 c
12 c
13 c
14 c
15 d
16 d
17 d
というデータが「サンプルデータ作成」で作成されたとすると、
(実際はもっとデータ数が多いです)
「A行情報変わる位置行挿入2」を実行後は、
A
1
2 a
3 a
4 a
5
6 b
7 b
8 b
9 b
10
11 c
12 c
13 c
14 c
15 c
16 c
17
18 d
19 d
20 d
となります。
試してみてください。
|
|