| |
エラー回避さん、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 "Ａ列にサンプルデータ作成"
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
３ a
４ a
５ b
６ b
７ b
８ b
９ c
１０ c
１１ c
１２ c
１３ c
１４ c
１５ d
１６ d
１７ d
というデータが「サンプルデータ作成」で作成されたとすると、
（実際はもっとデータ数が多いです）
「A行情報変わる位置行挿入2」を実行後は、
Ａ
１
２ a
３ a
４ a
５
６ b
７ b
８ b
９ b
１０
１１ c
１２ c
１３ c
１４ c
１５ c
１６ c
１７
１８ d
１９ d
２０ d
となります。
試してみてください。
|
|
ichinose
- 06/6/16(金) 20:21 -
