【質問4】

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


sheet4の
B列から◎列までの3行目のセルには
1以上の数字が入力されている。
sheet6の一行目がオートフィルタになってる。

sheet4の各列3行目セルの数字と同じ数を、sheet6のM列(M1)のオートフィルタで選択し、

例)
sheet4のB3=3ならば、sheet6のM1のオートフィルタを3を選択。
sheet4のD3=5ならば、sheet6のM1のオートフィルタを5を選択。

sheet6のオートフィルタ適用後のM列の文字が入っているセルを選択しコピー。
(セルM△からM▲まで、M△:M▲。△は文字が入っている最初の行、▲は文字が入っている最終行。M△~M▲のセルには空白なし)

sheet4の各列の最終行の次の行を先頭に、形式を選択して値を貼付け。
コピー解除。

以上をB列から◎列まで繰り返し


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

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

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/03/17 23:56:00

ポイント800pt

Sheet4ではなく、Sheet6のi列になりますでしょうか。

その場合はこうなります。


Sub macro4()
    Dim maxColumn As Integer
    Dim c As Integer
    Dim num As Integer
    Dim r As Long
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    
    maxColumn = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
    lastRow2 = Worksheets("Sheet6").Cells(Rows.Count, 13).End(xlUp).Row
    With Worksheets("Sheet4")
    For c = 2 To maxColumn
        num = .Cells(3, c).Value
        lastRow1 = .Cells(Rows.Count, c).End(xlUp).Row + 1
        For r = 1 To lastRow2
            If Worksheets("Sheet6").Cells(r, 13).Value = num Then
                .Cells(lastRow1, c).Value = Worksheets("Sheet6").Cells(r, 9).Value
                lastRow1 = lastRow1 + 1
            End If
        Next r
    Next
    End With
End Sub
id:pinko_pinpin

SALINGER様

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

SALINGER様のご推察のとおり、訂正の質問自体も間違っていました。

ご慧眼に敬服いたします。

それから例の件ですが、状況について理解しました。

今後ともよろしくお願い致します。

2009/03/18 20:17:15

その他の回答(2件)

id:SALINGER No.1

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

ポイント27pt

オートフィルタは使わなくてもいいようでしたので。

形式を選択して値を貼付けで、どのような貼り付けをしたのかが抜けているのでその部分はコピーにしています。

指定していただければ変更します。

Sub macro4()
    Dim maxColumn As Integer
    Dim c As Integer
    Dim num As Integer
    Dim r As Long
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    
    maxColumn = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
    lastRow2 = Worksheets("Sheet6").Cells(Rows.Count, 13).End(xlUp).Row
    With Worksheets("Sheet4")
    For c = 2 To maxColumn
        num = .Cells(3, c).Value
        lastRow1 = .Cells(Rows.Count, c).End(xlUp).Row + 1
        For r = 1 To lastRow2
            If Worksheets("Sheet6").Cells(r, 13).Value = num Then
                Worksheets("Sheet6").Cells(r, 13).Copy .Cells(lastRow1, c)
                lastRow1 = lastRow1 + 1
            End If
        Next r
    Next
    End With
End Sub
id:pinko_pinpin

あっ、質問を間違えました。

申し訳ありません。

sheet6のM1のオートフィルタを、sheet4B列から◎列までそれぞれ3行目の数字を適用し、適用された結果のsheet4のI列の行を選択し、

sheet4の各列の最終行の次の行を先頭に、形式を選択して値を貼付け。

コピー解除でした。

大変お手数ですが、もう一度お願いできますでしょうか?

2009/03/17 23:42:44
id:Mook No.2

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

ポイント400pt

先に続けて、Q1からQ4の処理です。

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)
'---- 開いているファイルを指定する場合はこっちを使用
'   Set dstWB = Workbooks("aaaa.xls")
    
    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

'// Q4 の処理
    Dim srcWS As Worksheet
    Set srcWS = dstWB.Worksheets("Sheet6")
    srcWS.Activate
    
    With dstWB.Worksheets("Sheet4")
        For c = 2 To lastCol
            srcWS.Rows(13).AutoFilter field:=13, Criteria1:="=" & .Cells(3, c).Value
            srcWS.Range("M1").Offset(1, 0).Select
            srcWS.Range(Selection, Selection.End(xlDown)).Copy _
                Destination:=.Cells(Rows.Count, c).End(xlUp).Offset(1, 0)
            srcWS.Rows(13).AutoFilter field:=13
        Next
    End With
End Sub
id:pinko_pinpin

ありがとうございます。

今後ともよろしくお願いいたします。

2009/03/17 23:23:09
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/03/17 23:56:00ここでベストアンサー

ポイント800pt

Sheet4ではなく、Sheet6のi列になりますでしょうか。

その場合はこうなります。


Sub macro4()
    Dim maxColumn As Integer
    Dim c As Integer
    Dim num As Integer
    Dim r As Long
    Dim lastRow1 As Long
    Dim lastRow2 As Long
    
    maxColumn = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
    lastRow2 = Worksheets("Sheet6").Cells(Rows.Count, 13).End(xlUp).Row
    With Worksheets("Sheet4")
    For c = 2 To maxColumn
        num = .Cells(3, c).Value
        lastRow1 = .Cells(Rows.Count, c).End(xlUp).Row + 1
        For r = 1 To lastRow2
            If Worksheets("Sheet6").Cells(r, 13).Value = num Then
                .Cells(lastRow1, c).Value = Worksheets("Sheet6").Cells(r, 9).Value
                lastRow1 = lastRow1 + 1
            End If
        Next r
    Next
    End With
End Sub
id:pinko_pinpin

SALINGER様

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

SALINGER様のご推察のとおり、訂正の質問自体も間違っていました。

ご慧眼に敬服いたします。

それから例の件ですが、状況について理解しました。

今後ともよろしくお願い致します。

2009/03/18 20:17:15
  • id:pinko_pinpin
    質問の間違えに気がつきました。
    申し訳ありません。
    sheet6のM1のオートフィルタを、sheet4B列から◎列までそれぞれ3行目の数字を適用し、適用された結果のsheet4のI列の行を選択し、
    sheet4の各列の最終行の次の行を先頭に、形式を選択して値を貼付け。
    コピー解除でした。
    大変お手数ですが、もう一度お願いできますでしょうか?
  • id:Mook
    もしかして、
    >適用された結果のsheet4のI列の行を選択し、

     適用された結果の sheet6 のI列の行を選択し、
    ですか?

    上記の解釈で、全体を整理したものをQ5に回答しました。
    Q5にも不備がありましたが、その中で対応しています。

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

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

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

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