Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7424 / 13644 ツリー ←次へ | 前へ→

【39047】Selection.Insert Shift:=xlDownのエラー エラー回避 06/6/16(金) 13:23 質問[未読]
【39057】Re:Selection.Insert Shift:=xlDownのエラー Jaka 06/6/16(金) 17:10 発言[未読]
【39063】Re:Selection.Insert Shift:=xlDownのエ... ichinose 06/6/16(金) 20:21 発言[未読]
【39242】Re:Selection.Insert Shift:=xlDownのエ... エラー回避さん 06/6/20(火) 13:19 発言[未読]
【39265】Re:Selection.Insert Shift:=xlDownのエ... ichinose 06/6/20(火) 18:29 発言[未読]

【39047】Selection.Insert Shift:=xlDownのエラー
質問  エラー回避  - 06/6/16(金) 13:23 -

引用なし
パスワード
   A 列の情報を比較
上下行で変わる場合 間に1行含ませたいが
下記状態で動きません

Sub  A行情報変わる位置行挿入()

'B列 列挿入     Range("B:B").Select
           Selection.Insert Shift:=xlToRight

'A2の情報をA1へ  Range("A2").Select
          Selection.Copy
          Range("A1").Select
          ActiveSheet.Paste

'数式入力      Range("B2").Select
           ActiveCell.FormulaR1C1 = "=EXACT(R[-1]C[-1],RC[-1])"

'B列オートフィルタ Selection.AutoFill Destination:=Range("B2:B1109")
'False値を抽出   Range("B2:B1109").Select
           Range("B1").Select
           Selection.AutoFilter
           Selection.AutoFilter Field:=2, Criteria1:="FALSE"
           Selection.SpecialCells(xlCellTypeVisible).Select
           Rows("1:1105").Select
'可視セルのみ選択  Selection.SpecialCells(xlCellTypeVisible).Select
 
'行挿入        Selection.Insert Shift:=xlDown 'データ消失を防ぐ為エラーRangeクラスメゾネットエラー
           Selection.AutoFilter Field:=2

'抽出の為の列削除  Rows("2:2").Select
           Selection.Delete Shift:=xlUp
            Columns("A:B").Select
            Range("B1").Activate
           Selection.Delete Shift:=xlToLeft
            Columns("A:A").Select
            Selection.Delete Shift:=xlToLeft
            Cells.Select
            Cells.EntireColumn.AutoFit
           Range("A1").Select
 End Sub

上記が直せるか
他 方法がありましたら教えてください

【39057】Re:Selection.Insert Shift:=xlDownのエ...
発言  Jaka  - 06/6/16(金) 17:10 -

引用なし
パスワード
   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クラスメゾネットエラー」
意味がわかりません。

【39063】Re:Selection.Insert Shift:=xlDownのエ...
発言  ichinose  - 06/6/16(金) 20:21 -

引用なし
パスワード
   エラー回避さん、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

となります。
試してみてください。

【39242】Re:Selection.Insert Shift:=xlDownのエ...
発言  エラー回避さん  - 06/6/20(火) 13:19 -

引用なし
パスワード
   ▼ichinose さん:
>エラー回避さん、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
>
>となります。
>試してみてください。

上記の通りです!!
ただ 既にA列に情報があり
そこから上記の結果を出したいのです
+もし可能なら作業グループ内同じ作業で
無理でしたら1Sheetごと 

目次項目1行目消し
AB列で並び替え
A列内容で上記の様に1行空け
AB列を消す

様になります。
申し訳ありません
ご伝授お願いします

【39265】Re:Selection.Insert Shift:=xlDownのエ...
発言  ichinose  - 06/6/20(火) 18:29 -

引用なし
パスワード
   ▼エラー回避さん さん:
こんにちは。
>>
>>新規ブックの標準モジュールに
>>
>>'=================================================================
>>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列にサンプルデータ作成"
'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
>>
>>となります。
>>試してみてください。
>
>上記の通りです!!
>ただ 既にA列に情報があり
>そこから上記の結果を出したいのです
ここもでは、上記に記述したとおりです。


>+もし可能なら作業グループ内同じ作業で
>無理でしたら1Sheetごと 
>
>目次項目1行目消し
>AB列で並び替え
>A列内容で上記の様に1行空け
>AB列を消す
>
>様になります。

↑これでは、私には何がなさりたいのか わかりません・・・。


私は、上記にあるようにプログラムの入力データにあたるA列のサンプルと

プログラム実行後、このようになるという結果を記述しましたよね!!
こういう表を作るのは、これだけでも結構面倒ですよね?
でも、この面倒な記述を質問者はしなければなりません。
それをすることがエラー回避さん さんにとって、
決してマイナスにはなりません(断乎として・・・)。
たとえ、回答が得られなかったとしてもです。

ここでは、

例えば、
xxx
xxx
xxx
xxx

のようなデータがxx列のyy行目からあった場合、

処理後は、

zzz
zzz
zzz
zzz

となるようにしたいと
記述してください。
例が一つでは不十分なら、二つでも三つでも記述してください。

7424 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free