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

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


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

▽最新の回答へ

1 ● SALINGER
●27ポイント

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

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

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

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
◎質問者からの返答

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

申し訳ありません。

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

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

コピー解除でした。

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


2 ● Mook
●400ポイント

先に続けて、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
◎質問者からの返答

ありがとうございます。

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


3 ● SALINGER
●800ポイント ベストアンサー

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
◎質問者からの返答

SALINGER様

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

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

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

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

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

関連質問


●質問をもっと探す●



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