Excel VBA質問箱 IV

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

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


12473 / 13645 ツリー ←次へ | 前へ→

【10231】デ−タ加工? yukko 04/1/13(火) 21:12 質問
【10236】Re:デ−タ加工? kein 04/1/14(水) 0:23 回答
【10264】Re:デ−タ加工? yukko 04/1/14(水) 20:20 お礼
【10265】Re:デ−タ加工? yukko 04/1/14(水) 21:46 質問
【10266】Re:デ−タ加工? kein 04/1/14(水) 22:42 回答
【10268】Re:デ−タ加工? yukko 04/1/14(水) 23:41 質問
【10277】Re:デ−タ加工? kein 04/1/15(木) 13:53 回答
【10286】Re:デ−タ加工? yukko 04/1/15(木) 19:30 質問
【10288】Re:デ−タ加工? kein 04/1/15(木) 23:33 回答
【10322】Re:デ−タ加工? yukko 04/1/18(日) 20:58 質問
【10325】Re:デ−タ加工? kein 04/1/18(日) 23:21 回答
【10326】Re:デ−タ加工? yukko 04/1/19(月) 0:04 回答
【10341】Re:デ−タ加工? kein 04/1/19(月) 17:36 回答
【10343】Re:デ−タ加工? yukko 04/1/19(月) 19:09 お礼
【10239】Re:デ−タ加工? ハマゾウ 04/1/14(水) 1:35 回答
【10241】Re:デ−タ加工? ichinose 04/1/14(水) 7:46 回答
【10262】Re:デ−タ加工? ハマゾウ 04/1/14(水) 16:43 お礼

【10231】デ−タ加工?
質問  yukko  - 04/1/13(火) 21:12 -

引用なし
パスワード
    こんばんわ、ちょっとお聞きしたいのですが
excelで下記のような表があります
  A  B  C  D  E・・・・・・・・・・200列
1 50.5 60.3 45.2 51.5 61.3
2 33.6 42.5 29.8 33.3 42.9
3 25.9 33.1 12.8 52.9 39.8
4 80.9 70.9 65.9 52.9 38.9
5 52.8 63.9 54.8 66.6 77.8
6 44.4 98.9 58.8 60.9 80.9
7 59.8 65.9 77.1 89.3 62.8
8




6000行
 このようにデ-タがあり、例えばA列の2行目(33.6)からA列の6行目(44.4)
の間でセルの値を消去します、5デ−タ消去したのでB列の1行目からB列の5行目まで
のデ−タをA列の最語尾に移動したいのです。
 そのときA列は1〜6000行までデ−タが入ってる状態です。 
それでB列は1〜5行目までのデ−タを移動したので6行目の98.9の値がB列の1行目
に移動してれば良いのですが。
 この時のB列のデ−タ数は5デ−タがA列に移動したので5995行です。
この作業をA列でした作業をC列でも行い、D列からC列で消去したデ−タ数を
移動します、この作業を繰り返し行います。
 *ちなみに、A列等でデ−タを消去するセル数や、消去する回数は不特定です。
こんな事が、可能か不可能か解りませんが何か良いアイデアがありましたら
教えて頂きたいのですが。
 宜しくお願いいたします。

【10236】Re:デ−タ加工?
回答  kein  - 04/1/14(水) 0:23 -

引用なし
パスワード
   >セルの値を消去
と言っても、クリアするのでなく"削除"するという意味ですね ?
となりの列からデータを持ってきて、なお
>そのときA列は1〜6000行までデ−タが入ってる
ということですからそのように解釈するとして、削除する範囲を選択し
以下のマクロを実行してみて下さい。選択範囲の条件は

1 必ず奇数列であること
2 列数は 1列のみ
3 選択範囲内に空白セルがない

ということになります。

Sub Data_Move()
  Dim x As Long, y As Long

  If TypeName(Selection) <> "Range" Then Exit Sub
  With Selection
   If .Columns.Count > 1 Then Exit Sub
   x = .Column: y = .Rows.Count
   If x Mod 2 = 0 Then Exit Sub
   If x >= Cells(256).End(xlToLeft).Column Then Exit Sub
   If WorksheetFunction.CountA(Selection) < .Cells.Count Then
     Exit Sub
   End If
   Application.ScreenUpdating = False
   .Delete xlShiftUp
  End With
  With Cells(1, x + 1).Resize(y)
   .Copy Cells(65536, x).End(xlUp).Offset(1)
   .Delete xlShiftUp
  End With
  Application.ScreenUpdating = True
End Sub

【10239】Re:デ−タ加工?
回答  ハマゾウ E-MAILWEB  - 04/1/14(水) 1:35 -

引用なし
パスワード
   ▼yukko さん:
表があるシートに以下のコードをコピーしてください。
削除したい範囲を選択後、Deleteキーで削除すればマクロが起動します。
もっと効率の良い方法があると思うのですが・・・
ご存知の方、ご指摘願います。

なお、シート名は"sheet1"としています。


Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim Cnt As Long
  Dim Flag As Boolean
  Dim DataA(1200000) As Double
  Dim DataB(5999, 199) As Double
  Dim DataC
  ReDim DataC(6000, 200) As Double
  
  If Cells(Target.Row, Target.Column).Value <> "" Then Exit Sub
  
  DataC = Sheets("sheet1").Range("a1:GR6000").Value
  k = 1
  For j = 1 To 200
    For i = 1 To 6000
      Flag = True
      If DataC(i, j) = 0 Then
        If Sheets("sheet1").Cells(i, j) = "" Then
          Flag = False
        End If
      End If
      If Flag = True Then
        DataA(k) = DataC(i, j)
        k = k + 1
      End If
    Next i
  Next j
  Cnt = 1200000 - k + 1
  
  k = 1
  For j = 0 To 199
    For i = 0 To 5999
      DataB(i, j) = DataA(k)
      k = k + 1
    Next i
  Next j
  
  Application.EnableEvents = False
  Sheets("sheet1").Range("a1:GR6000") = DataB()
  
  i = 6001
  j = 200
  For k = 1 To Cnt
    If i = 1 Then
      i = 6000
      j = j - 1
    Else
      i = i - 1
    End If
    Sheets("sheet1").Cells(i, j) = ""
  Next k
  Application.EnableEvents = True
        
End Sub

【10241】Re:デ−タ加工?
回答  ichinose  - 04/1/14(水) 7:46 -

引用なし
パスワード
   yukkoさん、keinさん、ハマゾウさん、おはようございます。

私も配列を使ってみました。
目的のデータを消去した状態(空白にする)でmainを実行してみて下さい。
>消去するセル数や、消去する回数は不特定です。
消去データは、虫食いのように飛び飛びの範囲でもOKです。

'=============================================================
Sub main()
  Application.ScreenUpdating = False
  Call データ加工(Range("a1:gr6000"))
'            ↑加工するセル範囲を指定します。
  Application.ScreenUpdating = True
End Sub
'=============================================================
Sub データ加工(rng As Range)
  Dim myarray
  Dim crow As Long
  Dim ccol As Long
  Dim frow As Long
  Dim fcol As Long
  myarray = rng.Value
  frow = 1
  fcol = 1
  For ccol = 1 To UBound(myarray, 2)
    For crow = 1 To UBound(myarray, 1)
     If myarray(crow, ccol) <> "" Then
       myarray(frow, fcol) = myarray(crow, ccol)
       If frow + 1 > UBound(myarray, 1) Then
        frow = 1
        fcol = fcol + 1
       Else
        frow = frow + 1
        End If
       End If
     Next
    Next
  For idx = fcol To UBound(myarray, 2)
    For jdx = frow To UBound(myarray, 1)
     myarray(jdx, idx) = ""
     Next jdx
    frow = 1
    Next idx
  rng.Value = myarray
End Sub

【10262】Re:デ−タ加工?
お礼  ハマゾウ E-MAIL  - 04/1/14(水) 16:43 -

引用なし
パスワード
   ▼yukkoさん、keinさん、そしてichinose さん、こんばんは。

ichinose さんの方法のように、配列の型をVariantにすれば0と""の識別が簡単にできるのですね。簡潔な記述とても参考になりました。ありがとうございます。

【10264】Re:デ−タ加工?
お礼  yukko  - 04/1/14(水) 20:20 -

引用なし
パスワード
    kein さん、ハマゾウさん、ichinoseさん
ありがとうございます、VBAは初心者なので
こんな事できるのかなと、思いながら投稿したのですが
驚きました。
 ありがとうございました、今後も宜しくお願いします。

 

【10265】Re:デ−タ加工?
質問  yukko  - 04/1/14(水) 21:46 -

引用なし
パスワード
    kein さん
こんばんわ、もし数値がA列の1行目から入力されてなく
例えば、10行目から入力されてればどの様にVBAを変更すれば
良いのでしょうか??

【10266】Re:デ−タ加工?
回答  kein  - 04/1/14(水) 22:42 -

引用なし
パスワード
   >A列の1行目から入力されてなく
A列ならセルを選択する方の列になりますよね ? それなら何行から始まっていても
関係ありません。とにかく選択した範囲を削除し、隣りの列から選択したセル数だけ
コピーしてくる。という動作になりますから。

【10268】Re:デ−タ加工?
質問  yukko  - 04/1/14(水) 23:41 -

引用なし
パスワード
   何度もごめんなさい kein さん
A列もB列も、1行目から10行目までは加工しなくてよいデ−タ
があり11行目から最終行までを加工する場合なのですが?

【10277】Re:デ−タ加工?
回答  kein  - 04/1/15(木) 13:53 -

引用なし
パスワード
   では、こんな感じで・・

Sub Data_Move()
  Dim x As Long, y As Long, z As Long

  If TypeName(Selection) <> "Range" Then Exit Sub
  With Selection
   If .Columns.Count > 1 Then Exit Sub
   x = .Column: y = .Rows.Count: z = .Row
   If z < 11 Then Exit Sub
   If x Mod 2 = 0 Then Exit Sub
   If x >= Cells(256).End(xlToLeft).Column Then Exit Sub
   If WorksheetFunction.CountA(Selection) < .Cells.Count Then
     Exit Sub
   End If
   Application.ScreenUpdating = False
   .Delete xlShiftUp
  End With
  With Cells(z, x + 1).Resize(y)
   .Copy Cells(65536, x).End(xlUp).Offset(1)
   .Delete xlShiftUp
  End With
  Application.ScreenUpdating = True
End Sub

【10286】Re:デ−タ加工?
質問  yukko  - 04/1/15(木) 19:30 -

引用なし
パスワード
    keinさん
こんばんわ、大変恐縮なのですが、うまく稼働しません。
A列の1行目から、デ−タが入力されていれば稼働するのですが
10行目以降からデ−タが、入力されていれば稼働しないのです。
  A B C D E・・・・・・・・・・・
1
2
3
4
5
6
7
8
9 これより上のデ−タは文字が入力加工の必要はありません
10 50 60 70 80 90
11 50 60 70 80 90






 私はBasic、ばかりだったのでVBAがどうも??
大変恐縮ですがお願いいたします。

【10288】Re:デ−タ加工?
回答  kein  - 04/1/15(木) 23:33 -

引用なし
パスワード
   ひょっとして空白セルも含めて選択してませんか ? 動かないというのは
「動く条件を厳しく制限してある」から、どこかでその制限に引っかかって
ストップするのだと思われます。
中止条件を判定しているコードに解説を付けておきますから、"ここの制限を外せば
いい" というところを見つけて、そのコードを削除してみて下さい。

Sub Data_Move()
  Dim x As Long, y As Long, z As Long

  If TypeName(Selection) <> "Range" Then Exit Sub
  'もし選択対象がセルでなかったら中止

  With Selection
   If .Columns.Count > 1 Then Exit Sub
   'もし選択範囲の列数が2列以上なら中止

   x = .Column: y = .Rows.Count: z = .Row
   'xは列番号、yは行数、zは先頭行の番号 

   If z < 11 Then Exit Sub
   'もし先頭行が10以下なら中止

   If x Mod 2 = 0 Then Exit Sub
   'もし列番号が偶数なら中止

   If x >= Cells(256).End(xlToLeft).Column Then Exit Sub
   'もし列番号がデータ入力範囲の最終列以上なら中止

   If WorksheetFunction.CountA(Selection) < .Cells.Count Then
   'もし選択範囲に空白セルがあったら

     Exit Sub
    '中止
   End If
   Application.ScreenUpdating = False
   .Delete xlShiftUp
  End With
  With Cells(z, x + 1).Resize(y)
   .Copy Cells(65536, x).End(xlUp).Offset(1)
   .Delete xlShiftUp
  End With
  Application.ScreenUpdating = True
End Sub

【10322】Re:デ−タ加工?
質問  yukko  - 04/1/18(日) 20:58 -

引用なし
パスワード
    kein さん
ありがとうございます、助かりました。
色々と手を加えて、出来るようになったのですが、
解決できない事が1つあるのです。
 大変恐縮なのですが、先頭行が10行以上でそれ以下の行にデ−タがあるセル、ないセル(空白)が不特定の場合、どの様に処理をすればよろしいでしょうか?
 お忙しいとは思いますが、教えて頂きたいのですが。

>Sub Data_Move()
>  Dim x As Long, y As Long, z As Long
>
>  If TypeName(Selection) <> "Range" Then Exit Sub
>  'もし選択対象がセルでなかったら中止
>
>  With Selection
>   If .Columns.Count > 1 Then Exit Sub
>   'もし選択範囲の列数が2列以上なら中止
>
>   x = .Column: y = .Rows.Count: z = .Row
>   'xは列番号、yは行数、zは先頭行の番号 
>
>   If z < 11 Then Exit Sub
>   'もし先頭行が10以下なら中止
>
>   If x Mod 2 = 0 Then Exit Sub
>   'もし列番号が偶数なら中止
>
>   If x >= Cells(256).End(xlToLeft).Column Then Exit Sub
>   'もし列番号がデータ入力範囲の最終列以上なら中止
>
>   If WorksheetFunction.CountA(Selection) < .Cells.Count Then
>   'もし選択範囲に空白セルがあったら
>
>     Exit Sub
>    '中止
>   End If
>   Application.ScreenUpdating = False
>   .Delete xlShiftUp
>  End With
>  With Cells(z, x + 1).Resize(y)
>   .Copy Cells(65536, x).End(xlUp).Offset(1)
>   .Delete xlShiftUp
>  End With
>  Application.ScreenUpdating = True
>End Sub

【10325】Re:デ−タ加工?
回答  kein  - 04/1/18(日) 23:21 -

引用なし
パスワード
   >色々と手を加えて、出来るようになった
どこに手を加えて、現在はどのようになってますか ? それを元にしないと、余計な
手間がかかります。
>どの様に処理をすれば
それはこちらが尋ねることです。選択列で空白セルを含む場合と、コピー元の列で
空白がある場合、少なくともその2つの状況でどうしたいか書かないと、サンプル
コードは作れませんが・・。

【10326】Re:デ−タ加工?
回答  yukko  - 04/1/19(月) 0:04 -

引用なし
パスワード
    kein さん
説明が下手でごめんなさいね・・
元々Keinさんの作成されたのを使って頂いて結構です。

つまり下記のようになってるパタ−ンがあるのです
  A B C D E F G・・・・
1   20 21 22 23 24
2 20 19 20 21
3
4 30 31 32 33
5   33 34 35
6
7 36 37 38
8
9
10 40 41 42 43 44
11
12




 この11行目からは、空白セルは無く
奇数列で消去したセル数のデ−タを偶数列からコピ−
できれば良いのですが・・
 ややこしいですが、11行目以上のデ−タをコピ−して
加工したいのです。
 10行目以下のデ−タはそのまま動かさずに。
10行目以下には、デ−タが入力されているセルと、空白のセルとが
ランダムになっています。
 宜しくお願いいたします・・時間は急いでいませんので。

【10341】Re:デ−タ加工?
回答  kein  - 04/1/19(月) 17:36 -

引用なし
パスワード
   最初の質問内容とは、だいぶ違ってますね・・。
ではこんな感じでどうでしょーか ? 今度はシートモジュールに入れるイベント
にしています。以前と違って「転記元の偶数列」で、転記したい値の先頭セルを
右クリックすると、そこから転記先の空白セル数ぶんだけ範囲が選択され、
出てきたメッセージで "はい" のボタンを押して、一つ前の列の空白セルに転記する。
という処理になります。偶数列で10行目以下の行をクリックしても、マクロは動き
ません。また、転記先(1つ前の列の1〜10行目)で空白セルが無い場合も、中止します。

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
Cancel As Boolean)
  Dim x As Integer, Bcnt As Integer, Ans As Integer
  Dim C As Range, PR As Range

  With Target
   If .Row < 11 Then Exit Sub
   x = .Column
  End With
  If x Mod 2 = 1 Then Exit Sub
  With Application.WorksheetFunction
   If .CountA(Columns(x)) = 0 Or _
   .CountA(Columns(x - 1)) = 0 Then
     Exit Sub
   End If
   Bcnt = .CountBlank(Cells(1, x - 1).Resize(10))
  End With
  If Bcnt = 0 Then Exit Sub
  Cancel = True
  Target.Resize(Bcnt).Select
  Ans = MsgBox("選択範囲の値を転記しますか", 36)
  If Ans = 7 Then Exit Sub
  For Each C In Selection
   Set PR = Cells(1, x - 1).Resize(10).SpecialCells(4)
   PR.Cells(1).Value = C.Value
   Set PR = Nothing
  Next
End Sub

【10343】Re:デ−タ加工?
お礼  yukko  - 04/1/19(月) 19:09 -

引用なし
パスワード
    keinさん
本当に恐縮いたします、ありがとうございます。
 今後も宜しくお願いします。

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