【質問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列。

回答の条件
  • 1人3回まで
  • 登録:2009/03/16 23:38:18
  • 終了:2009/03/17 23:20:02

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/03/17 02:10:22

ポイント400pt

一連の処理のようなので、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
id:pinko_pinpin

ありがとうございます。

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

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

2009/03/17 23:19:11

その他の回答(2件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/03/17 02:10:22ここでベストアンサー

ポイント400pt

一連の処理のようなので、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
id:pinko_pinpin

ありがとうございます。

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

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

2009/03/17 23:19:11
id:SALINGER No.2

SALINGER回答回数3430ベストアンサー獲得回数9692009/03/17 01:35:08

ポイント27pt
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
id:SALINGER No.3

SALINGER回答回数3430ベストアンサー獲得回数9692009/03/17 02:04:38

ポイント400pt

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
id:pinko_pinpin

ありがとうございます。

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

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

2009/03/17 23:19:19
  • id:pinko_pinpin
    すいません。ポイントをお付けできました。
  • id:SALINGER
    たくさんのポイントありがとうございます。
    複数の人が回答してる場合は、総額で400でも構わないと思いますよ。

    それと、Case 3 が Case 32 となってましたね。
  • id:Mook
    SALINGERさんのコメントに同意です。

    まだ終了していない分は、こちらでの配分を差し引いてただいて結構です。
    (もちろん回答内容に不備があれば、配点自体不要ですが。)

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません