Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

12473 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【10231】デ－タ加工？ ｙｕｋｋｏ 04/1/13(火) 21:12

【10236】Re:デ－タ加工？ kein 04/1/14(水) 0:23

【10264】Re:デ－タ加工？ ｙｕｋｋｏ 04/1/14(水) 20:20

【10265】Re:デ－タ加工？ ｙｕｋｋｏ 04/1/14(水) 21:46

【10266】Re:デ－タ加工？ kein 04/1/14(水) 22:42

【10268】Re:デ－タ加工？ ｙｕｋｋｏ 04/1/14(水) 23:41

【10277】Re:デ－タ加工？ kein 04/1/15(木) 13:53

【10286】Re:デ－タ加工？ ｙｕｋｋｏ 04/1/15(木) 19:30

【10288】Re:デ－タ加工？ kein 04/1/15(木) 23:33

【10322】Re:デ－タ加工？ ｙｕｋｋｏ 04/1/18(日) 20:58

【10325】Re:デ－タ加工？ kein 04/1/18(日) 23:21

【10326】Re:デ－タ加工？ ｙｕｋｋｏ 04/1/19(月) 0:04

【10341】Re:デ－タ加工？ kein 04/1/19(月) 17:36

【10343】Re:デ－タ加工？ ｙｕｋｋｏ 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】デ－タ加工？

ｙｕｋｋｏ - 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:デ－タ加工？

ハマゾウ

- 04/1/14(水) 1:35 -


	引用なし

	パスワード

▼ｙｕｋｋｏさん：
表があるシートに以下のコードをコピーしてください。
削除したい範囲を選択後、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 -


	引用なし

	パスワード

ｙｕｋｋｏさん、keinさん、ハマゾウさん、おはようございます。

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

'=============================================================
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:デ－タ加工？

ハマゾウ

- 04/1/14(水) 16:43 -


	引用なし

	パスワード

▼ｙｕｋｋｏさん、keinさん、そしてichinose さん、こんばんは。

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


	【10264】Re:デ－タ加工？

ｙｕｋｋｏ - 04/1/14(水) 20:20 -


	引用なし

	パスワード

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

　


	【10265】Re:デ－タ加工？

ｙｕｋｋｏ - 04/1/14(水) 21:46 -


	引用なし

	パスワード

　kein さん
こんばんわ、もし数値がA列の１行目から入力されてなく
例えば、１０行目から入力されてればどの様にVBAを変更すれば
良いのでしょうか？？


	【10266】Re:デ－タ加工？

kein - 04/1/14(水) 22:42 -


	引用なし

	パスワード

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


	【10268】Re:デ－タ加工？

ｙｕｋｋｏ - 04/1/14(水) 23:41 -


	引用なし

	パスワード

何度もごめんなさい kein さん
A列もＢ列も、１行目から１０行目までは加工しなくてよいデ－タ
があり１１行目から最終行までを加工する場合なのですが？


	【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:デ－タ加工？

ｙｕｋｋｏ - 04/1/15(木) 19:30 -


	引用なし

	パスワード

　keinさん
こんばんわ、大変恐縮なのですが、うまく稼働しません。
A列の１行目から、デ－タが入力されていれば稼働するのですが
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:デ－タ加工？

ｙｕｋｋｏ - 04/1/18(日) 20:58 -


	引用なし

	パスワード

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

>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 -


	引用なし

	パスワード

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


	【10326】Re:デ－タ加工？

ｙｕｋｋｏ - 04/1/19(月) 0:04 -


	引用なし

	パスワード

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

つまり下記のようになってるパタ－ンがあるのです
　Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ・・・・
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:デ－タ加工？

ｙｕｋｋｏ - 04/1/19(月) 19:09 -


	引用なし

	パスワード

　keinさん
本当に恐縮いたします、ありがとうございます。
　今後も宜しくお願いします。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

12473 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free