- ベストアンサー
２行にわたる値を1行にまとめるには？
merlionXXの回答
- merlionXX
- ベストアンサー率48% (1930/4007)
要は2重に採番されたA列のコード番号は無視してB列の「商品名」ごとに、それぞれのC～X列にある売上を合計すればいいのですね？ データがあるシートをSheet1、集計先をSheet2とします。 データは１行目からあるものとし、B列の商品名には途中の空白セルは存在しないものとします。 以上の前提でよければ以下のコードをお試しください。 Sub test01() Dim myDic As Object Dim ms As Worksheet, ns As Worksheet Dim c As Range, i As Integer, dta As String Set myDic = CreateObject("Scripting.Dictionary") Set ms = Sheets("Sheet1") Set ns = Sheets("Sheet2") For i = 1 To 22 For Each c In ms.Range(ms.Cells(1, "B"), ms.Cells(Rows.Count, "B").End(xlUp)) dta = c.Value If Not myDic.exists(dta) Then myDic.Add dta, c.Offset(0, i).Value Else myDic(dta) = myDic(dta) + c.Offset(0, i).Value End If Next c ns.Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Keys) ns.Range("B1").Offset(0, i).Resize(myDic.Count, 1).Value = Application.Transpose(myDic.Items) myDic.RemoveAll Next i Set myDic = Nothing Set ms = Nothing Set ns = Nothing End Sub
関連するQ&A
- マクロセルの値によってセルの色を消す
エクセル2013です。 セルの値が0又は空白の場合でそのセルが色塗りされていたら色を消す というマクロをを作成しました。 ただ700行55列では処理が遅いです。 Sub 色消() '成功 Dim 最終行 Dim 最終列 Dim 対象セル As Range 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 For Each 対象セル In Range(Cells(10, 17), Cells(最終行, 最終列)) If 対象セル.Value = 0 Or 対象セル = "" Then 対象セル.Interior.ColorIndex = 0 End If Next 対象セル End Sub 対象範囲から対象セルを全部見つけて一括処理すれば早いのではと 以下のマクロを作成してみましたが Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole) で構文ERRです。 どこを直せばいいのでしょうか？ よろしくお願いします。 Sub 色消2() '2014/8/4 '失敗 Dim 対象範囲 Dim 最終行 Dim 最終列 最終列 = Cells(8, Columns.Count).End(xlToLeft).Column '8行目の最終列を取得 最終行 = Cells(Rows.Count, 1).End(xlUp).Row 'A列の最終行を取得 対象範囲 = Range(Cells(10, 17), Cells(最終行, 最終列)) Set 対象範囲 = Cells.Find(What:=0 Or "", LookIn:=xlValues, LookAt:=xlWhole) If Not 対象範囲 Is Nothing Then 対象範囲.Interior.ColorIndex = 0 End If End Sub
- ベストアンサー
- Excel（エクセル）
- EXCELマクロで特定の行以下をコピーしたい
BookA.xlsファイルからBookB.cvsがあり、 bookB.csvには1から不特定に数字が昇順にならんでいます bookB.csv A B 1 1 文字列A 2 2 文字列B 3 54 文字列C 4 100 文字列D 5 101 文字列E BookA.xlsからbookB.csvを読出し、特定の数値（100番）を探し出し その行から下100行をコピー、BookA.xlsのSheetCに貼り付け という作業をするマクロを組みたいと思っています。 'CSVファイルを開く CSVname = Application.GetOpenFilename(Title:="CSVファイル指定", fileFilter:="CSV ファイル (*.CSV), *.csv") If CSVname = False Then MsgBox "ファイルを１個指定して下さい" Exit Sub End If 'ファイルをひらく Workbooks.Open CSVname '100番検索 Set Obj = Cells.Find("100", LookAt:=xlWhole) If Obj Is Nothing Then MsgBox "見つかりませんでした。" Else Tate = Cells.Find("100", LookAt:=xlWhole).Row End If 'A列100番のある行から199行を選択・コピー エラー→Range(Cells(1, Tate), Cells(2, Tate)).Select このように作ってみたのですが、どうしてもここでエラーになり 先に進めません。 どうか解決方法をお教え下さい。 宜しくお願いします。
- ベストアンサー
- オフィス系ソフト
- 特定文がある行を削除
特定分がある行を削除しようと思い、以下のように設定いたしました。 Sub DelLines() Dim R As Range Do Set R = ActiveSheet.Range("A:A").Find(What:="指定文", LookAt:=xlWhole) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop End Sub これを、全てのシートに適用するにはどのように書けばよろしいのでしょうか？
- ベストアンサー
- Excel（エクセル）
- ExcelVBAで行と列の検索
Ａ Ｂ Ｃ Ｄ Ｅ １ コード あ い う え ２ １０ ○ ○ ３ ２０ ○ ○ ４ ３０ ○ 上記の表が5000件あります。Textbox1に入力し検索ボタンを押すと A列のコードを検索して一致する列の○のあるところの１行目の項目 をtextbox2に表示したいのですがうまく行きません。 よろしくお願い致します。 Private Sub CommandButton1_Click() '検索フォームボタン Dim i As Long Dim 最終行 As String Dim サーチ行 As Long Sheets(1).Activate 最終行 = Range("A1").End(xlDown).Row サーチ行 = 0 For i = 2 To 最終行 If TextBox1.Value = Range("A" & i) Then If Range("B" & i, "N" & i) = "" Then TextBox2.Text = Range("B1", "N1") サーチ行 = i Exit For End If End If Next If サーチ行 = 0 Then MsgBox TextBox1.Value & "データはありません。", vbInformation, "無し" End If TextBox1.SetFocus End Sub エラーはでません。データはありませんとなります。
- ベストアンサー
- その他（プログラミング・開発）
- 行の削除
列Ｋに、削除という文字が入っている場合は、その行を削除するということで、3000行くらいあるなかで3分の2程度は削除する行に該当します。 下のマクロで試してみましたが、このマクロではとっても時間がかかってしまうんですが、どうしたら早く処理できるのか教えて下さい。 Dim R As Range Do Set R = ActiveSheet.Range("K:K").Find(What:="削除", LookAt:=xlWhole) If R Is Nothing Then Exit Sub R.EntireRow.Delete Loop
- 締切済み
- その他(ソフトウェア)
- エクセルマクロの質問。値の変更のイベントについて
エクセルのマクロを勉強中です。 仕事で使いたいのですが、わからなくて困っています。 教えていただけないでしょうか。 商品受注の表でシート1（商品マスター）に商品マスター（Ａ3に「商品コード」Ｂ3に「商品名」Ｃ3に「型番」Ｄ3に「単価」）があります。 シート2（入力用）は、Ａ3に「商品コード」Ｂ3に「商品名」Ｃ3に「型番」Ｄ3に「単価」Ｅ3に「注文総計」Ｆ3に「Ａ社分」（Ａ社からの受注数）Ｇ3に「Ｂ社分」（Ｂ社からの受注数）Ｈ3に「合計」（Ａ社分とＢ社分の合計）Ｈ3に「チェック」（注文総計と合計の差で同じだと○を表示）があります。 注文総数というのは、Ａ社とＢ社から受注した数の合計で、どちらからいくつ受注したのかは、別に出てくる伝票を数えないとわかりません。 やりたいことは (1) 「商品コード」を手入力すると、商品マスターから「商品名」「型番」「単価」が入力される。 「商品コード」に該当ないコードを入力すると、メッセージがでる。 (2)「注文総数」と「Ａ社分」と「Ｂ社分」を手入力すると、「合計」と「チェック」が入力される。 「商品コード」の入力があるのに「注文総数」等数値の入力が無い場合は、0とみなして計算する。 以上の(1)と(2)の手入力分が入力（変更）されしだい、自動に入力される分が入力（変更）するようにしたいのです。 今のところ、ボタンを作って(1)と(2)を動かしているのですが、自動にすることもエラー処理部分ができません・・・ ちなみに自分で作った（見よう見まねです）のは以下です。 (1) Sub 商品マスターコピー() ' '*** 入力の最後行までを別シートにコピー（vlookup) ' 最終行 = Range("A" & Rows.Count).End(xlUp).Row '入力した商品名の最終行の検索 For 行 = 4 To 最終行 If Range("A" & 行).Value <> "" Then Range("B" & 行) = Application.WorksheetFunction.VLookup(Range("A" & 行), Worksheets("商品マスター").Range("A:D"), 2, False) '商品マスターから商品名をコピー Range("C" & 行) = Application.WorksheetFunction.VLookup(Range("A" & 行), Worksheets("商品マスター").Range("A:D"), 3, False) '商品マスターから型番をコピー Range("D" & 行) = Application.WorksheetFunction.VLookup(Range("A" & 行), Worksheets("商品マスター").Range("A:D"), 4, False) '商品マスターから単価をコピー End If Next End Sub (2) Sub 注文数集計() ' '*** 列全てに集計（足し算、引き算、if文）結果を表示 最終行 = Range("A" & Rows.Count).End(xlUp).Row '入力した商品名の最終行の検索 For 行 = 4 To 最終行 If Range("A" & 行).Value <> "" Then Range("H" & 行) = Application.WorksheetFunction.Sum(Range("F" & 行), Range("G" & 行)) 'H列に（明細あり+明細なし）を表示 ' Range("I" & 行) = Range("E" & 行) - Range("H" & 行) 'I列に（総合計-受注数）の差額を表示 Range("I" & 行) = IIf(Range("E" & 行) - Range("H" & 行) = 0, "○", Range("E" & 行) - Range("H" & 行)) '計-受注数）の差額を表示 End If Next End Sub 説明が下手なので上手く伝えられたか心配ですが・・・どうぞよろしくお願いいたします。
- ベストアンサー
- その他MS Office製品
- Excel VBA でテキストボックスの値をセルA列から検索
いつもお世話になります。 Private Sub CommandButton3_Click() Dim 行 As String Dim 列 As String Dim 最終行 As String Dim 検索行 As String Dim メッセージ As Integer Dim 一致 As Range Dim myNO As Variant Dim i As Long Sheets(3).Select 最終行 = Range("A2").End(xlDown).Offset(1).Select 行 = ActiveCell.Row 列 = ActiveCell.Column myNO = TextBox2.Value 検索行 = Range("A2").End(xlDown).Select ※・・・Set 一致 = Range("A2:検索検").Findwhat:=TextBox2,lookat:=xlWhole) If 一致 Is Nothing Then MsgBox "データがありません。新規コード入力します。" Cells(行, 列 + 0) = UserForm1.TextBox2.Value Cells(行, 列 + 1) = UserForm1.ComboBox7.Value Else i = Cells(行 - 1, "A") Cells(i, 列 + 0) = UserForm1.TextBox2.Value Cells(i, 列 + 1) = UserForm1.ComboBox7.Value End If End Sub 「エラー1004'Range'メソッドは失敗しました'Global'オブジェクト」とでます。※印が黄色になっています。 ユーザーフォーム1のテキストボックスの値をシート3のA列から検索して、一致すれば、A列の一致セルに上書き入力して、一致が無い場合はA列の空白セルに追加入力したいのです。よろしくお願い致します。
- ベストアンサー
- その他（プログラミング・開発）
- VBAで複数の行のナンバーを取得し、その行の列の値を参照して値を入れる
下記のことをしたいのですが、調べてもわかりません。 どなたか教えてください。 よろしくお願いします。 内容： エクセルシートのA列の値が11である行ナンバーを取得（複数ある可能性があります）する。 その行のE列（5列目）の値と他のテーブルの値を参照して所定の値をA列の値が11である行のE列（5列目）に返す。 以下のVBAを書いてみましたがうまくいきません。 ----------------------------------------------------------------- Dim ROWCOUNT As Integer Dim row_array() As Variant Dim i As Integer '全行数を取得 ROWCOUNT=Worksheets("sheet1").Range("A1",Range("A65536").End(xlUp)).Count For i = 1 To ROWCOUNT If Cells(i, 1).Value = 11 Then Cells(i,1).Offset(0,5).Value=WorksheetFunction.VLookup(Cells(i, 1).Offset(0, 5).Value, Worksheets("sheet2").Range("A1:H1786"), 3, False) End If Next I
- ベストアンサー
- その他（プログラミング・開発）
- 13行目のセルの値が0のとき、その列を非表示にする
Windows7 Excel2007でマクロ作成中の初心者です。 13行目のセルの値が、0のときは、その列を非表示にするというマクロを作ろうとしましたが なかなか難しくておてあげです。探したら次のようなコードがでてきました。 ボタンを押すとK列の値を参照して「A」と表示されている行を隠し、「表示する」ボタンを押すと、 解除するという処理。 Option Explicit Private Sub Cmd隠す_Click() Dim 行番号 As Long '行を隠す For 行番号 = 4 To 13 If Cells(行番号, 11).Value = "A" Then Cells(行番号, 1).EntireRow.Hidden = True End If Next 行番号 End Sub Private Sub Cmd表示する_Click() '表全体を再表示する Cells.Select Selection.EntireRow.Hidden = False Selection.EntireColumn.Hidden = False Cells(1, 1).Select End Sub このコードを利用して、13行目のセルの値が、0のときは、その列を非表示にするというコードにしたいのです。 よろしくおねがいします。
- ベストアンサー
- Visual Basic
- E列が空白のとき、その空白行を削除し、番号を振り直す
windows7 Excel2003でマクロ勉強中です。 あるサイトにE列が空白のとき、その空白行を削除し、番号を振り直すという コードがありました。 自分で作った表（表の最上段の２行は項目名が入っています。）で 実行すると「Rangeメソッドは失敗しました。Globalオブジェクト」と エラーが出ます。エラーはでますが、処理自体は正しく実行されます。 このエラーの原因と回避するにはどうしたらよろしいでしょうか。 Sub E列が空白のとき、その空白行を削除し、番号を振り直す() Dim i As Long, j As Long '行削除の処理 For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1 If Range("A" & i).Value <> "" And IsNumeric(Range("A" & i).Value) = True Then If Range("E" & i).Value = "" Then Rows(i).Delete End If End If Next '番号振りなおし処理 '’’Range("A" & Rows.Count).End(xlUp).Offset(1).Select For i = 0 To Range("A" & Rows.Count).End(xlUp).Row If Range("A" & i).Value = "番号" Then j = 1 ・・・・・ここでエラー発生 If Range("A" & i).Value <> "" And IsNumeric(Range("A" & i).Value) = True Then Range("A" & i).Value = j j = j + 1 End If Next ActiveSheet.Protect End Sub
- ベストアンサー
- Visual Basic
補足
No.3のVBAで実行して2行から1行へはできました。 ただ、質問上と事実上の表は違っていて、B1の上にも日付や、担当名や記号など色々入っていたのですが、それをつけてVBAを手直しして（B,1の部分を相当する番号に直して）実行させたらそれらが消えてしまいました。 手直しが足らないのでしょうか？