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

【質問3】
エクセルのマクロを作って下さい。
文章が下手なもので理解しづらいかもしれませんが、宜しくお願い致します。
私の要望通りのものでしたら、400ポイントを差し上げます。

エクセルファイルの
sheet4の
B列から◎列までの2行目のセルには
2?4の数字が入力されている。

sheet4:B2が2ならば、sheet5のA10:A20をコピー、
sheet4:B2が3ならば、sheet5のB10:B21をコピー、
sheet4:B2が4ならば、sheet5のC10:C25をコピー、
B列最終行の次の行を先頭に貼付け

sheet4:C2が2ならば、sheet5のA10:A20をコピー、
sheet4:C2が3ならば、sheet5のB10:B21をコピー、
sheet4:C2が4ならば、sheet5のC10:C25をコピー、
C列最終行の次の行を先頭に貼付け

sheet4:D2が2ならば、sheet5のA10:A20をコピー、
sheet4:D2が3ならば、sheet5のB10:B21をコピー、
sheet4:D2が4ならば、sheet5のC10:C25をコピー、
D列最終行の次の行を先頭に貼付け

以下◎列まで繰り返し


◎列はB列から横にsheet1(質問1)の行数◆を行列を入替えた列
例えば、sheet1の最終行が11行だとするとL列、
sheet1の最終行が15行だとするとP列。

●質問者: pinko_pinpin
●カテゴリ:コンピュータ
✍キーワード:A10 b2 B21 D2 エクセル
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● Mook
●400ポイント ベストアンサー

一連の処理のようなので、Q1からQ3までを行う部分を一つにしました。

別々に行う必要があるようでしたら、コメントください。

Sub pinkoQs()
'// Q1 の処理
 Dim Path As String, WSH As Variant
 Set WSH = CreateObject("WScript.Shell")
 
 Path = WSH.SpecialFolders("MyDocuments") & "\cccc\aaaa.xls"
 Dim dstWB As Workbook
 Set dstWB = Workbooks.Open(Path)
 
 Path = WSH.SpecialFolders("MyDocuments") & "\cccc\bbbb.csv"
 Dim srcWB As Workbook
 Set srcWB = Workbooks.Open(Path)
 
 Dim lastRow As Long
 lastRow = srcWB.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
 
 srcWB.Worksheets(1).Range("A2").Resize(21, lastRow - 1).Copy _
 Destination:=dstWB.Worksheets("Sheet1").Range("A2").Resize(21, lastRow - 1)
 srcWB.Close

'// Q2 の処理
 dstWB.Worksheets("Sheet2").Activate
 Dim r As Long
 For r = 3 To lastRow - 1
 dstWB.Worksheets("Sheet2").Range("A3:M3").Copy _
 Destination:=dstWB.Worksheets("Sheet2").Range("A1").Offset(r, 0).Resize(1, 13)
 Next
 
 dstWB.Worksheets("Sheet3").Activate
 For r = 3 To lastRow - 1
 dstWB.Worksheets("Sheet3").Range("A3:L3").Copy _
 Destination:=dstWB.Worksheets("Sheet3").Range("A1").Offset(r, 0).Resize(1, 12)
 Next

'// Q3 の処理
 With dstWB.Worksheets("Sheet4")
 .Activate
 Dim lastCol As Long
 lastCol = lastRow
 For c = 2 To lastCol
 lastRow = .Cells(Rows.Count, c).End(xlUp).Row + 1
 Select Case .Cells(2, c).Value
 Case 2
 Debug.Print .Cells(Rows.Count, c).End(xlUp).Address
 dstWB.Worksheets("Sheet5").Range("A10:A20").Copy _
 Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
 Case 3
 dstWB.Worksheets("Sheet5").Range("B10:B21").Copy _
 Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
 Case 4
 dstWB.Worksheets("Sheet5").Range("C10:C25").Copy _
 Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
 End Select
 Next
 End With
End Sub
◎質問者からの返答

ありがとうございます。

ポイントを差し上げるにはどうした良いのでしょうか?

自ら差し上げるとコメントしていながら申し訳ありません、、、、


2 ● SALINGER
●27ポイント
Sub macro3()
 Dim maxColumn As Long
 Dim c As Integer
 Dim lastRow As Long
 
 maxColumn = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
 With Worksheets("Sheet4")
 For c = 2 To maxColumn
 lastRow = .Cells(Rows.Count, c).End(xlUp).Row + 1
 
 Select Case .Cells(2, c).Value
 Case 2
 Worksheets("Sheet5").Range("A10:A20").Copy .Cells(lastRow, c)
 Case 32
 Worksheets("Sheet5").Range("B10:B21").Copy .Cells(lastRow, c)
 Case 4
 Worksheets("Sheet5").Range("C10:C25").Copy .Cells(lastRow, c)
 End Select
 Next c
 
 End With
End Sub

3 ● SALINGER
●400ポイント

1ヶ所だけ訂正です。

Sub macro3()
 Dim maxColumn As Long
 Dim c As Integer
 Dim lastRow As Long
 
 maxColumn = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
 With Worksheets("Sheet4")
 For c = 2 To maxColumn
 lastRow = .Cells(Rows.Count, c).End(xlUp).Row + 1
 
 Select Case .Cells(2, c).Value
 Case 2
 Worksheets("Sheet5").Range("A10:A20").Copy .Cells(lastRow, c)
 Case 32
 Worksheets("Sheet5").Range("B10:B21").Copy .Cells(lastRow, c)
 Case 4
 Worksheets("Sheet5").Range("C10:C25").Copy .Cells(lastRow, c)
 End Select
 Next c
 
 End With
End Sub
◎質問者からの返答

ありがとうございます。

ポイントを差し上げるにはどうした良いのでしょうか?

自ら差し上げるとコメントしていながら申し訳ありません、、、、

関連質問


●質問をもっと探す●



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