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

エクセルVBAについて質問です。次のページにあるような2つのマクロを作ってください。
http://hatena88.web.fc2.com/hatena/newpage1.shtml
なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えてください。
http://q.hatena.ne.jp/1158311664

●質問者: taroemon
●カテゴリ:学習・教育
✍キーワード:VBA エクセル マクロ 勉強 回答者
○ 状態 :終了
└ 回答数 : 2/3件

▽最新の回答へ

1 ● kn1967
●40ポイント

>同一の文字列が2個以上あった場合、最後尾に「設定」というシートが作成され


手順を少し変えると楽になります。

(1)設定というシートを作成

(2)列を指定させる

(3)指定された列すべてを設定シートのA列にコピー

(4)設定シートのA列をソート

(5)一番下のセルを選択して、それよりも上に同じものがあれば削除、1つ上のセルを選択して、それよりも、、、以下同文というループ


この方法であれば前回ご質問の回答2

http://q.hatena.ne.jp/1169694559 を少し改造するだけです。


(1)?(3)に関しては、

S_Range = "A:E": 'ここではA列からE列と設定

という一行を

S_Range = InputBox("A:AやB:Bの形で列を入力してください")

という一行に変えてダイアログボックスを出すようにします。

そして、

Sheets(Sheets.Count).Name = "合計": 'シート見出し

Sheets(Sheets.Count).Name = "設定": 'シート見出し

に、

Sheets("合計").Select: 'シート選択

Sheets("設定").Select: 'シート選択

に変えます。


(4)は

最後の

obj_Sheets.Select: '元もと選択されていた状態に戻す

の必要性がなくなりましたので消して、

Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod :=xlPinYin

に変えます。


(5)は(4)の下に

Cells(65535, 1).End(xlUp).Select:'最下行に移動

Do

If Activecell.Value = Activecell.Offset(-1,0).Value Then'1つ上のセルと同じ内容なら

Activecell.Value = "":'空っぽにする

End If

loop while Activecell.Row > 1:'1行目に達していなければDoに戻る

Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod :=xlPinYin

最後にもう一度ソートすれば虫食いがなくなる。


以上、いきなり書いてますので記述ミスがあるかもしれませんが、学習中ということで、改造にチャレンジしてみて下さい。

なお、マクロ2は前回ご質問の回答1の改造で対応可能です。

◎質問者からの返答

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

できればできあがった物を提示していただけると助かります。

ただご指摘、ご指導には感謝します。


2 ● たか
●200ポイント
Sub マクロ1()
 Dim st, st2 As Worksheet
 Dim y, y2, x, x2, z As Integer
 Dim h_for, h_sheet As Integer
 Dim ny As Integer
 Dim WSN() As String
 Dim i, j As Integer
'st,x,yをメイン、st2,x2,y2を判定用とします

'##### 初期設定 ########################################
 h_for = 0 'for文の判定に使用
 h_sheet = 0 '設定シートの有無に使用(1=有,0=無)
 ny = 1 '設定シートの入力行開始位置(1=1行目)
 nx = 1 '設定シートの入力列開始位置(1=A列)
 x = 2 'データシートの指定する列(2=B列)
 
'##### 全シート選択処理 ################################
 i = Worksheets.Count 'シート数をカウント
 ReDim WSN(1 To i) 'シート名の変数の数を設定
 For j = 1 To i
 WSN(j) = Sheets(j).Name 'シート名を変数に格納
 Next

'##### メイン処理 ######################################
'全シートを一つずつstに返し、以下の処理を繰り返します
 For Each st In Sheets(WSN)
 st.Select
 
'データが100行になるか空白になるまで繰り返します(100は可変)
 For y = 1 To 100
 If (st.Cells(y, x) = "") Then
 Exit For
 End If
 
'判定用に全シート、100行までチェックします(100は可変)
 For Each st2 In Sheets(WSN)
 For y2 = 1 To 100
 If (st2.Cells(y2, x) = "") Then
 Exit For
 End If

'メインと判定用が全く同じ場所をチェックするのを防ぎます
 If (y = y2 And st.Name = st2.Name) Then
 Else
 
'メインと判定用が同じであるかチェックします
 If (st.Cells(y, x) = st2.Cells(y2, x)) Then
 
'「設定」シートの有無をチェックし、なければ一番最後にシートを追加します
 If (h_sheet = 0) Then
 Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
 ActiveSheet.Name = "設定"
 h_sheet = 1
 End If
 
'「設定」シートに既に同じものがないかチェックします(2重書き込みの防止)
 For z = ny To 100
 If (Sheets("設定").Cells(z, 1) = st.Cells(y, x)) Then
 Exit For
 End If

'「設定」シートの入力開始行から空白になる所にデータをコピーします
 If (Sheets("設定").Cells(z, 1) = "") Then
 Sheets("設定").Cells(z, nx) = st.Cells(y, x)
 Exit For
 End If
 Next
 h_for = 1
 Exit For
 End If
 End If
 Next

'1つコピーが完了すればメインデータを次の行にいく為、forを抜けます
 If (h_for = 1) Then
 h_for = 0
 Exit For
 End If
 Next
 Next
 Next
 Sheets("設定").Select
End Sub


Sub マクロ2()
 Dim x, x2, x3, y, y2 As Integer
 Dim WSN() As String
 Dim i, j As Integer
 Dim st As Worksheet
 
'##### 初期設定 ########################################
 x = 1 '設定シートのデータ位置(1=A列)
 x2 = 2 'データシートの指定する位置(2=B列)
 x3 = 4 'データシートの「別の列」位置(4=D列)
 
'##### 全シート選択処理 ################################
 i = Worksheets.Count
 ReDim WSN(1 To i)
 For j = 1 To i
 WSN(j) = Sheets(j).Name
 Next

'##### メイン処理 ######################################
'「設定」シートのデータ位置が100行、もしくは空白になるまで繰り返します
 For y = 1 To 100
 If (Sheets("設定").Cells(y, x) = "") Then
 Exit For
 End If
 
'設定シート以外、全シート処理を繰り返します
 For Each st In Sheets(WSN)
 If (st.Name = "設定") Then
 Exit For
 End If
 
'データシートのデータが100行、もしくは空白になるまで繰り返します
 For y2 = 1 To 100
 If (st.Cells(y2, x2) = "") Then
 Exit For
 End If
 
'設定シートのデータとデータシートのデータが同じであれば
 If (st.Cells(y2, x2) = Sheets("設定").Cells(y, x)) Then
 
'設定シートのデータの隣(マニュアルで入力する列)をデータシートの指定位置にコピーします
 st.Cells(y2, x3) = Sheets("設定").Cells(y, x + 1)
 End If
 Next
 Next
 Next
End Sub

http://www.hatena.ne.jp/

◎質問者からの返答

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

完璧に出来ました。

また機会がありましたら、

よろしくご回答下さいませ。

関連質問


●質問をもっと探す●



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