人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

<エクセルマクロ>データ群の並列(条件付き)
エクセルSheet2のA1?Anセル(nは変数)にある文字列(数値列混在)群を同一エクセルSheer1のX列のX1以下に貼り付けて積み下げていくマクロが欲しいです。X1?Xnセルに貼り付けたら、次はX(n+1)に同じものを貼り付けする。(Xについて、「貼りつける列はどこにしますか?」というメッセージボックスがでると幸いです。)
また、貼り付け作業は、X列の(αn+1)(αは正の整数で1、2、3、4、5、6と増えていく)を見て、空欄になるまで、データの貼り付けを続ける。
というマクロが希望です。
図示すると以下の様になります。

(例示)Sheet2のA1?Anセル(nは変数)にある文字列(数値列混在)群=x ,y,z (例は n=3)と仮定すると
マクロ実行前は、X列は空欄で、マクロ実行後は下記の様になるマクロ
X-1列,X列, X+1列
a, x
a, y
a, z
??途中略???
b, x
b, y
b, z
c, x
c, y
c, z
空欄 空欄(左のセルが空欄なのでここでストップ)

上記のようなマクロできますか?よろしくお願いいたします。


●質問者: hirohirohiro777
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:A1 X1 エクセル ストッ セル
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● Ktwo
●100ポイント ベストアンサー

例示に合わせて作成してみやした。

Option Explicit

Dim sN As String
Dim lN As Long
Dim sColumn As String
Dim sColumn_Left As String
Dim lRow As Long
Dim lCounter As Long

Public Sub Macro1()
On Error GoTo Macro1_Error

Dim sColumn As String

 sN = InputBox("変数nを指定して下さい?", "Sheet2のコピー元件数指定")
 lN = CLng(sN)
 
 sColumn = InputBox("貼りつける列はどこにしますか?", "列選択", "X")
 sColumn = UCase(sColumn)
 
 '入力チェック&左列決定
 If LenB(sColumn) < 2 Or LenB(sColumn) > 4 _
 Then
 MsgBox "Input Error 001": GoTo Macro1_Exit
 End If
 Select Case LenB(sColumn)
 Case 2
 If sColumn < "B" Or sColumn > "Z" _
 Then
 MsgBox "Input Error 002": GoTo Macro1_Exit
 End If
 sColumn_Left = Chr(Asc(sColumn) - 1) '<= 左列決定
 Case 4
 If MidB(sColumn, 1, 2) < "A" Or MidB(sColumn, 1, 2) > "Z" Or _
 MidB(sColumn, 3, 2) < "A" Or MidB(sColumn, 3, 2) > "Z" _
 Then
 MsgBox "Input Error 003": GoTo Macro1_Exit
 End If
 If MidB(sColumn, 3, 2) <> "A" _
 Then
 sColumn_Left = MidB(sColumn, 1, 2) _
 & Chr(Asc(MidB(sColumn, 3, 2)) - 1) '<= 左列決定
 Else
 If MidB(sColumn, 1, 2) <> "A" _
 Then
 sColumn_Left = Chr(Asc(MidB(sColumn, 1, 2)) - 1) _
 & "Z" '<= 左列決定
 Else
 sColumn_Left = "Z" '<= 左列決定
 End If
 End If
 End Select
 
 '積み下げ処理
 Sheets("Sheet1").Select
 lCounter = 0
 lRow = 1
 Do Until IsEmpty(Sheet1.Range(sColumn_Left & CStr(lRow)).Value)
 
 lCounter = lCounter + 1
 If lCounter > lN _
 Then
 lCounter = 1
 End If
 
 Sheet2.Range("A" & CStr(lCounter)).Copy
 Sheet1.Range(sColumn & CStr(lRow)).Select
 ActiveSheet.Paste
 
 lRow = lRow + 1
 
 Loop
 
Macro1_Exit:
 If Application.CutCopyMode = xlCopy _
 Then
 Application.CutCopyMode = False
 End If
 
 MsgBox "Finished"
 
 Exit Sub
 
Macro1_Error:

 MsgBox "!! ERROR !!" & vbCr & vbCr & Err.Description

End Sub

Cellsを使うと、左列決定が楽になると思いますが、

敢えて、Rangeのみで・・・?>°)mニニニニ=?

EXCELのオブジェクト(セルの指定)

http://homepage2.nifty.com/kasayan/vba/excel2.htm

◎質問者からの返答

Ktwoさん

完璧なマクロで大変感謝感激です。

ありがとうございました。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ