• ベストアンサー
  • 困ってます

VBA 検索をかけ合計数とGrp番号を抽出    

現在、関数ではなく VBAでマクロを勉強しているのですが、 下記のコードでエラーが発生してしまいます。 是非、ご教授願えませんでしょうか。 Sheet3を作業用のSheetとして使用しています。  Sub Sample1() Dim i As Long, k As Long, lastRow As Long, wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet2") Set wS3 = Worksheets("Sheet3") Application.ScreenUpdating = False With Worksheets("Sheet1") lastRow = .Cells(Rows.Count, "A").End(xlUp).Row .Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True For i = 2 To wS3.Cells(Rows.Count, "B").End(xlUp).Row .Range("B1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "B") Range(.Cells(3, "B"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(3, (i - 1) * 2) For k = wS2.Cells(Rows.Count, (i - 1) * 2).End(xlUp).Row To 2 Step -1 wS2.Cells(k, (i - 1) * 2 - 1) = WorksheetFunction.CountIfs(.Range("A:A"), wS3.Cells(i, "A"), _ .Range("C:C"), wS2.Cells(k, (i - 1) * 2)) For j = 2 To wS3.Cells(Rows.Count, "E").End(xlUp).Row .Range("E1").AutoFilter field:=1, Criteria1:=wS3.Cells(j, "E") Range(.Cells(3, "E"), .Cells(lastRow, "E")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(3, (j - 1) * 2) For l = wS2.Cells(Rows.Count, (j - 1) * 2).End(xlUp).Row To 2 Step -1 wS2.Cells(j, (j - 1) * 2 - 1) = WorksheetFunction.CountIfs(.Range("A:A"), wS3.Cells(j, "A"), _ .Range("E:E"), wS2.Cells(k, (j - 1) * 2)) If WorksheetFunction.CountIf(wS2.Columns((j - 1) * 2), wS2.Cells(k, (j - 1) * 2)) > 1 Then wS2.Cells(l, (j - 1) * 2 - 1).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub 実際に抽出結果を出したい概要は下記に用になります。 検索したいsheet1には セルBにはUsername番号などがあります。      A        B       C     D     E     F     G 1           Username      Grp番号    2           yamada10x      Grp1             3           yamada4x       Grp1    4           yamada10x      Grp1 5           yamada10x      Grp1 6           yamada4x       Grp2 7           yamada10x      Grp2 8           yamada4x       Grp2 9           yamada10x      Grp3 . . 50           yamada4x      Grp40 Sheet2にはセルBとCにyamada10xの合計数とgrp番号、セルEとFにはyamada4xの合計数とgrp番号などがあります。      A        B          C       D        E           F      1 2       yamada10xの合計数 Grp番号       yamada4xの合計数  Grp番号   3                                   4                                  5               . . 10                                          sheet1で検索したユーザ名・Grp番号などを行数3のセルC・FにはGrp番号を抽出 行数3のセルB・EにはGrp番号ごとのyamada10xとyamada4xの合計数をsheet2に 抽出させたいという形になります。       A        B          C       D        E          F      1 2       yamada10xの合計数  Grp番号       yamada4xの合計数 Grp番号   3               3         Grp1            1        Grp1 4               1         Grp2            2        Grp2 5               1         Grp3 . . 10                                         1       Grp40 わかりにくい図と説明で申し訳ございません。 お手数をおかけしますが、ご教授の方をお願いできますでしょうか。 よろしくお願い致します。

共感・応援の気持ちを伝えよう!

  • 回答数3
  • 閲覧数269
  • ありがとう数10

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.3
  • tom04
  • ベストアンサー率49% (2537/5117)

No.1です。 結局、行・列合わせだけの問題だと思います。 質問ではSheet1のB列は2種類だけですが、何種類あっても対応できるようにしてみました。 Sheet2の他の列に数式などが入っていてはいけませんので、 D:E列・I:J列・N:O列・・・と5列おきに操作しています。 Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet2") Set wS3 = Worksheets("Sheet3") Application.ScreenUpdating = False If wS2.Range("A1") = "" Then wS2.Range("A1") = "ダミー" End If lastRow = wS2.UsedRange.Rows.Count lastCol = wS2.Cells(10, Columns.Count).End(xlToLeft).Column If lastRow > 9 Then For j = 4 To lastCol Step 5 Range(wS2.Cells(10, j), wS2.Cells(lastRow, j + 1)).ClearContents Next j End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(4, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(10, (i - 2) * 5 + 4) = .Range("F4") wS2.Cells(10, (i - 2) * 5 + 5) = wS3.Cells(i, "A") wS2.Cells(10, (i - 2) * 5 + 5).NumberFormatLocal = "@の合計数" .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "F"), .Cells(lastRow, "F")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(11, (i - 2) * 5 + 4) For k = wS2.Cells(Rows.Count, (i - 2) * 5 + 4).End(xlUp).Row To 11 Step -1 wS2.Cells(k, (i - 2) * 5 + 5) = WorksheetFunction.CountIfs(.Range("F:F"), wS2.Cells(k, (i - 2) * 5 + 4), .Range("B:B"), _ wS2.Cells(10, (i - 2) * 5 + 5)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 5 + 4), wS2.Cells(k, (i - 2) * 5 + 4)) > 1 Then wS2.Cells(k, (i - 2) * 5 + 4).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Columns.AutoFit wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub 今度はどうでしょうか?m(_ _)m

共感・感謝の気持ちを伝えよう!

質問者からのお礼

回答ありがとうごいました。 何度もお答えしてもらい申し訳ありません。 VBAの方でマクロ組むことができました。 是非、参考にしていきたいと思います

関連するQ&A

  • Excel VBA 検索してその合計数を抽出

    はじめまして、業務用で下記の用にExcel VBABasicでマクロを 組みたいのですが、組み方の方がわかりません。 是非、ご教授願えませんでしょうか。 Ms Oficeは2010です。 検索したいsheet1には ユーザの名前とGrp番号などがあります。      A        B     C     D     E     F     G 1 Username   Grp番号    2 yamada10x   Grp1             3 yamada4x    Grp1    4 yamada10x   Grp1 5 yamada10x   Grp1 6 yamada4x    Grp2 7 yamada10x   Grp2 8 yamada4x    Grp2 9 yamada10x   Grp3 . . 50 yamada4x    grp40 Sheet2にはyamada10xやyamada4xの合計数とGrp番号などがあります       A              B       C             D       E     F      1  yamada10xの合計数 Grp番号  yamada4xの合計数  Grp番号   2                  3  4 5 sheet1で検索したGrp番号などの合計数を下記の用にGrp番号にはGrp1などを抽出 そのGrp番号に合ったyamada10xやyamada4xの合計数などをsheet2に抽出させたいのですが       A              B       C             D       E     F      1  yamada10xの合計数 Grp番号  yamada4xの合計数  Grp番号   2     3             Grp1     1            Grp1 3     1             Grp2     2            Grp2 4     1             Grp3 . . 10                           1            Grp40 わかりにくい図で申し訳ございません。 お手数をおかけしますが、ご教授の方をお願いできますでしょうか。 よろしくお願い致します。

  • VBA 検索するSheetの位置の変更

    現在、グループの数だけユーザー名の合計数をSheet2に抽出するという 事をやっているのですが....... コードの方は下記になります Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet1") Set wS3 = Worksheets("Sheet2") Application.ScreenUpdating = False If wS2.Range("Y1") = "" Then wS2.Range("Y1") = "ダミー" End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _ wS2.Cells(7, (i - 2) * 8 + 3)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。 lastRow = .Cells(Rows.Count, "C").End(xlUp).Row Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _ どなたかご教授の方お願い致します。

  • Excel VBA 連番印刷

    昨日以下の質問をさせていただいた者です。 http://okwave.jp/qa/q8349562.html こちらで教えていただいた以下のコードに、 J2のセルに連番を振るコードを付け足したいと思い、 同じくこちらのサイトの過去の履歴にあった以下コードを参考にとやってみているのですが、 Next で指定された変数の参照が無効です。と言われてしまいます… 印刷部数の指定はいらず、sheet印刷のJ2セルに1から始まる連番を振りたいのです。 どのように修正をしたらいいのかご教示願います。 Sub Sample4() Dim i As Long, endRow1 As Long, endRow2 As Long, myArea1 As Range, myArea2 As Range Dim wS1 As Worksheet, wS2 As Worksheet, wS3 As Worksheet Set wS1 = Worksheets("DB") Set wS2 = Worksheets("印刷") Set wS3 = Worksheets("Sheet3") endRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row Range(wS1.Cells(1, "A"), wS1.Cells(endRow1, "A")).AdvancedFilter Action:=xlFilterInPlace, unique:=True wS1.Range("A:A").Copy wS3.Range("A1") wS1.ShowAllData For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row If endRow2 > 9 Then Range(wS2.Cells(10, "B"), wS2.Cells(endRow2, "H")).ClearContents Range(wS2.Cells(10, "J"), wS2.Cells(endRow2, "J")).ClearContents End If wS1.Range("A1").AutoFilter field:=1, Criteria1:=wS3.Cells(i, "A") wS2.Range("B6") = wS3.Cells(i, "A") Set myArea1 = Range(wS1.Cells(2, "B"), wS1.Cells(endRow1, "H")).SpecialCells(xlCellTypeVisible) Set myArea2 = Range(wS1.Cells(2, "I"), wS1.Cells(endRow1, "I")).SpecialCells(xlCellTypeVisible) myArea1.Copy wS2.Activate ActiveSheet.Range("B10").Select Selection.PasteSpecial Paste:=xlPasteValues myArea2.Copy wS2.Activate ActiveSheet.Range("J10").Select Selection.PasteSpecial Paste:=xlPasteValues endRow2 = wS2.Cells(Rows.Count, "B").End(xlUp).Row 'Range(wS2.Cells(1, "A"), wS2.Cells(endRow2, "J")).PrintOut Next i wS1.AutoFilterMode = False wS3.Cells.Clear End Sub 連番印刷のコード Sub NumberPrint() Dim idx As Integer Dim res  res = Application.InputBox("印刷部数を入力してください", Type:=1)  If res > 0 Then   For idx = 1 To res    Range("AW3").Value = idx    ActiveSheet.PrintOut   Next idx  End If End Sub

その他の回答 (2)

  • 回答No.2

以下でどうでしょう。 Sheet1が選ばれている状態で実行すると、新シートに表示されます。 提示された記述ほど難しい事はしていないので、コメントなくても・・・ Public Sub Samp1()   Dim dic As Object   Dim sS As String   Dim vS As Variant, v As Variant   Dim B As Long, D As Long   Dim i As Long, j As Long   Set dic = CreateObject("Scripting.Dictionary")   B = Range("B1").Column   D = Range("D1").Column   For i = 2 To Cells(Rows.Count, B).End(xlUp).Row     sS = Cells(i, B).Value     If (Not dic.Exists(sS)) Then       dic.Add sS, CreateObject("Scripting.Dictionary")     End If     v = Cells(i, D).Value     dic(sS)(v) = dic(sS)(v) + 1   Next   Worksheets.Add After:=ActiveSheet   i = 0   For Each vS In dic.Keys     With Range("B2").Offset(, i)       .Resize(, 2).Value = Array(vS & "の合計数", "Grp番号")       j = 1       For Each v In dic(vS).Keys         .Offset(j).Resize(, 2).Value = Array(dic(vS)(v), v)         j = j + 1       Next       With .Resize(j, 2)         .Sort .Cells(2), xlAscending, Header:=xlYes       End With     End With     i = i + 3   Next   With Cells     .HorizontalAlignment = xlCenter     .EntireColumn.AutoFit   End With   Set dic = Nothing End Sub

共感・感謝の気持ちを伝えよう!

質問者からのお礼

お礼送れて申し訳ございません 回答ありがとうございます。 参考にさせて頂きたいと思います

  • 回答No.1
  • tom04
  • ベストアンサー率49% (2537/5117)

こんにちは! http://okwave.jp/qa/q8773631.html と同じ内容ですね? COUNTIFS関数で解決済みだったみたいですが・・・ 今度はVBAで!というコトのようですので、 VBAの場合、1行・1列違ってもエラーになったり、 動いたとしてもデタラメな結果になってしまいます。 前回の場合はSheet1のA・B列のデータでしたので、おそらくこのコードで大丈夫だったはずですが、 今回は前回のA列がB列に B列がD列に移動しているようなので コード内容を変更しなければなりません。 前回のコードに手を加えてみました。Sheet1は1行目が項目行で、データは2行目以降にあるとします。 標準モジュールです。 Sub Sample2() Dim i As Long, k As Long, lastRow As Long, wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet2") Set wS3 = Worksheets("Sheet3") Application.ScreenUpdating = False lastRow = wS2.UsedRange.Rows.Count '★Sheet2の3行目からの表示なので、一旦2行目以降を消去 If lastRow > 1 Then wS2.Rows(2 & ":" & lastRow).Clear End If With Worksheets("Sheet1") lastRow = .Cells(Rows.Count, "B").End(xlUp).Row '★ .Range("B:B").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row .Range("A1").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") '★ wS2.Cells(2, (i - 1) * 3 - 1) = wS3.Cells(i, "A") & "の合計数" '★ wS2.Cells(2, (i - 1) * 3) = "Grp番号" '★ Range(.Cells(2, "D"), .Cells(lastRow, "D")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(3, (i - 1) * 3) '★ For k = wS2.Cells(Rows.Count, (i - 1) * 3).End(xlUp).Row To 3 Step -1 '★ wS2.Cells(k, (i - 1) * 3 - 1) = WorksheetFunction.CountIfs(.Range("B:B"), wS3.Cells(i, "A"), _ .Range("D:D"), wS2.Cells(k, (i - 1) * 3)) '★ If WorksheetFunction.CountIf(wS2.Columns((i - 1) * 3), wS2.Cells(k, (i - 1) * 3)) > 1 Then '★ wS2.Cells(k, (i - 1) * 3 - 1).Resize(, 2).Delete shift:=xlUp '★ End If Next k Next i wS2.Columns.AutoFit wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub ※ コード内の「★」の部分に手を加えています(列合わせのため) ※ 元データがB・D列でない場合はとんでもない表示になります。m(_ _)m

共感・感謝の気持ちを伝えよう!

質問者からの補足

何度もの質問に答えて頂きありがとうございます。 Sub Sample2() コードの方を使いましたら問題なく 実行の方ができました。 補足という事ですが、失礼とは存知ますがもう一度質問の方を させていただいてもよろしいでしょうか? Sheet1の検索したいUsername・Grp番号のセルが違う場所にある場合、 Sheet2の検索結果も出したいセルの位置を各違うセルの位置に出したいという場合になります。 検索したいSheet1では、行数5(セルB)にはUsername 行数5(セルF)にGrp番号という形です。      A     B     C     D     E     F     G 1 2 3 4        Username                  Grp番号    5        yamada10x                  Grp1    6         yamada4x                  Grp1  7        yamada10x                  Grp1  8        yamada10x                  Grp2  8        yamada10x                  Grp2 . 50        yamada4x                  Grp40  sheet1で検索したユーザ名・Grp番号などを行数10のセルD・IにはGrp番号を抽出 行数3のセルE・JにはGrp番号ごとのyamada10xとyamada4xの合計数をsheet2に 抽出、Grp番号と合計数のセルの位置を逆にyamada10xとyamada4xの合計数をセルD.EとI.Jと遠い セルの位置にずらしたいという形です。       D      E         F     G     H     I     J 10  Grp番号 yamada10xの合計数               Grp番号  yamada4xの合計数 11   Grp1     2                         Grp1     1 12   Grp2     1                         Grp2     1 13   Grp3     1                         Grp3     1 14   Grp4     2                         Grp4     1 ・  ・  20   grp10     1 何度もを質問して申し訳ございませんが、 ご教授の方お願いしてもよろしいでしょうか?                          

関連するQ&A

  • VBA 変数について

    VBA初心者でございます。 VBAでgrpという変数を設定し、それをキーにしてオートフィルタをしたいです。 以下のコードではエラーがでてしまうのは、なぜでしょうか? どうぞ宜しくお願いいたします。 Sub 絞り込み2() Dim grp Set grp = Worksheets("リスト").Cells(3, 2) Worksheets("マスタ0701").AutoFilterMode = False With Worksheets("マスタ0701").Range(Cells(3, "B"), Cells(Rows.Count, "CK").End(xlUp)) .AutoFilter Field:=13, Criteria1:=grp '.CurrentRegion.Select Range(Cells(3, "B"), Cells(Rows.Count, "CK").End(xlUp)).SpecialCells(xlVisible).Copy Worksheets("検索結果").Range("A1") '.AutoFilter End With End Sub

  • COUNTIFS関数をVBAで使用したい

    お世話になります。 よろしくお願いいたします。 Sheet1に集計表、Sheet2にデーターがあります。 氏名とコードが合致するデーターの個数を出したいのですが、コードの書き方がわかりません。 ご教示をお願いいたします。 Sheet1のB列の最後に小計や合計が入っているため、A列使用。 COUNTIFS関数でコンパイルエラーがでます。 Sheet1 A    B   C    D 氏名 氏名 コード 合致する個数 Sheet2 B    J     N 氏名  コード   数値 Sub test1() Dim i As Long, t As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS1.Range("A" & Rows.Count).End(xlUp).Row t = wS2.Range("B" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For i = 5 To i Range(wS1.Cells(5, "D"), wS1.Cells(i, "D")).Formula = _ "=COUNTIFS(wS2.Range("B7:B"&t),B5,wS2.Range("J5:J"&t),C5)" Next i Application.ScreenUpdating = True End Sub

  • 行列で検索をかけてその結果を転記するVBAは

    早速ですが質問させていただきます。 sheet1のA列に月日、2行目に製品名をとり製品個数を記した表があります。(列数150行数1000です)これをsheet3のCells(2, 6)に記入した月日とCells(2, 4)に記入した製品名(文字)の2つでsheet1の行と列から当てはまるセルの検索をコマンドボタンを押すことにより行い、そのセルにsheet3のCells(2, 7)に記入した製品個数を転記するようなVBAを書きました。 Private Sub CommandButton1_Click() Dim LastA, idxA As Long, trgA, trgB With Worksheets("Sheet3") LastA = .Range("A1000").End(xlUp).Row trgA = Application.Match(.Cells(2, 6), Worksheets("Sheet1").Range("A:A"), 0) For idxA = LastA To 3 Step -1 trgB = Application.Match(.Cells(2, 4), Worksheets("Sheet1").Range("2:2"), 0) Worksheets("Sheet1").Cells(trgA, trgB) = .Cells(2, 7) Next idxA End With End Sub 以前質問して教えていただいたものを参考に、少し変更してみたのですがこれで正しいでしょうか?実行するとうまく転記するのですがかなり時間がかかってしまい、もう少し何とかならないものかと思っています。どなたかご指導お願いします。

  • エクセルVBAの記述の違い

    下記の2つともA1:B2の中身を削除するものですが、test1の書き方だと対象となるシートがアクティブではないとエラーになります。test2は問題なし。 Cellsの書き方のほうが変数を使う時に便利なのですが、なんでこんな違いがでてしまうのでしょうか? Sub test1() Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Range(Cells(1, 1), Cells(2, 2)).ClearContents ws2.Range(Cells(1, 1), Cells(2, 2)).ClearContents End Sub Sub test2() Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Range("a1:b2").ClearContents ws2.Range("a1:b2").ClearContents End Sub

  • VBA 別シートからコピー貼付け(複数列)

    別シートからコピー貼付け(複数列)をしたいのですが,同一シートからのコピー貼付けはネットから以下のマクロでできました。 しかし,別シートsheet1からsheet2ヘコピーで修正しましたが,「アプリケーション定義またはオブジェクト定義のエラーです。」となります。どなたかご教授よろしくお願いします。 修正したマクロ Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Sheets("sheet2").Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Sheets("sheet1").Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub 参考としたマクロ http://www.excel.studio-kazu.jp/kw/20041208152106.html Sub sampel() Dim i As Long For i = 2 To Range("E65536").End(xlUp).Row Step 2 Range(Cells(i + 1, 2), Cells(i + 1, 85)).Value = _ Range(Cells(i, 5), Cells(i, 88)).Value Next i End Sub

  • EXCEL VBA 早く処理をする

    よろしくお願いします 下の構文を標準モジュールに書き込み、callで実行しているのですが 処理に時間がかかります。 処理を早くする方法と構文の簡素化のご教示をお願いします。 Application.ScreenUpdating = False For i = 1 To 12 With Worksheets(i) .Select LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending .Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8" LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A" & LastRow).Select Dim EndRow As Long EndRow = .Range("A" & Rows.Count).End(xlUp).Row Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = .Name & "合計" Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = "前月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7") Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = "次月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = "合計" Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6) .Range("C7").End(xlDown).Select Selection.Offset(4, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 2).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 3).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 4).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(0, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 2).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 3).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 4).Borders(xlEdgeBottom).Weight = xlThin End With Next i Application.ScreenUpdating = True

  • エクセルのVBAの記述について

    VBAの記述についてなのですが、 Sub filter() Dim gyo As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Set ws1 = Worksheets("データ") Set ws2 = Worksheets("チーム") Application.ScreenUpdating = False ws2.Range("A4:BH30").Clear gyo = ws1.Range("A65536").End(xlUp).Row ws1.Activate With ws1.Range(Cells(4, 1), Cells(gyo, 6)) .AutoFilter Field:=1, Criteria1:="A" .SpecialCells(xlCellTypeVisible).Copy ws2.Range("A4") Selection.AutoFilter End With Application.ScreenUpdating = True End Sub ならプログラムははしるのですが、 14行目を .SpecialCells(xlCellTypeVisible).Copy ws2.Range(Cells(4, 1)) だと 「実行時エラー 1004 Rangeメソッドは失敗しました Worksheet オブジェクト」 とでるのですが、出来ないのでしょうか? Cells(4, 1)の1のところを変数にして変えていきたいのですが、よい方法はありますか。 よろしくお願いいたします。

  • VBAで変数が使いこなせなくて、困っています

    エクセル VBAで、 「業者コードを入力すると、業者の名前と電話番号を表示してくれる。」 というVBAを、本を見ながら作ったのですが、(下にコピペしました↓) これだと業者コードが増える度、VBAに入力していかなければならないことに。 業者さんはどんどん増えていくので、追いつかなく困っています。 iを使ったり応用しようとしましたが、自力ではどうも無理なのです。 初めてなので、説明不足でしたらすみません。 どうかお願いします! ------------------------------------------------------------ Sub 業者コードから入力() ' Dim getstr As String Dim msg As String Dim title As String Set ws1 = Worksheets("データ") Set ws2 = Worksheets("業者コード") Set ws3 = Worksheets("通知書") msg = "業者コードを入力してください" title = "コード入力" getstr = InputBox(msg, title) getstr = UCase(getstr) Select Case getstr Case "00" ws3.Range("d6") = ws2.Range("e7") ws3.Range("d9") = ws2.Range("i7") ws3.Range("q9") = ws2.Range("j7") Case "01" ws3.Range("d6") = ws2.Range("e8") ws3.Range("d9") = ws2.Range("i8") ws3.Range("q9") = ws2.Range("j8") Case "02" ws3.Range("d6") = ws2.Range("e9") ws3.Range("d9") = ws2.Range("i9") ws3.Range("q9") = ws2.Range("j9") Case "03" ws3.Range("d6") = ws2.Range("e10") ws3.Range("d9") = ws2.Range("i10") ws3.Range("q9") = ws2.Range("j10") Case "04" ws3.Range("d6") = ws2.Range("e11") ws3.Range("d9") = ws2.Range("i11") ws3.Range("q9") = ws2.Range("j11") Case "05" ws3.Range("d6") = ws2.Range("e12") ws3.Range("d9") = ws2.Range("i12") ws3.Range("q9") = ws2.Range("j12")   Case Else     MsgBox "エラーです" End Select End Sub ------------------------------------------------------------

  • ExcelVBAで画像の様に動作を変更したいです

    先日、こちらにて 教えていただいたマクロでのデータ突合方法を基にマクロを作成中なのですが、 画像の様に動作させるにはどう修正すればよいでしょうか (目標) 画像のSheet1 と Sheet2の商品コードを上から順に突合し、 Sheet3に合致したA品番をコピー Sheet4に合致したB品番をコピー Sheet5に合致しなかったA品番をコピー Sheet6に合致しなかったB品番をコピー ※なお、A品番B品番ともに同じ値の品番がいくつか存在することがある。 この場合は、ループ中既に合致したデータは対象から外す。 判別方法は品番の一つ横のセルに”〇”を表記。(フラグを立てる) 「A品番=B品番」のとき「Offset(0, 1)が”〇”」ならば合致しない  --------------------------------------------------- (手順) (1)Sheet1 あり Sheet2 ありの場合 →一致したSheet1とSheet2のOffset(0, 1)に”〇” →一致したSheet1の行全体の値をSheet3にコピー →一致したSheet2の行全体の値をSheet4にコピー (2)Sheet1 あり Sheet2 なしの場合 →該当するSheet1の行全体の値をSheet5にコピー (3)Sheet1 なし Sheet2 ありの場合 →該当するSheet2の行全体の値をSheet6にコピー --------------------------------------------------- (現在のコード) Sub Test() Dim c As Range, FRange As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp)) Set FRange = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)). _ Find(c.Value, LookAt:=xlWhole, After:=Sh2.Cells(Rows.Count, "A").End(xlUp)) If Not FRange Is Nothing Then If c.Value = FRange.Value And FRange.Offset(1, 0).Value <> "◯" Then c.Offset(0, 1).Value = "◯" '↓(1).xlsmSheet2に Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value FRange.Offset(0, 1).Value = "◯" End If Else '↓(1).xlsmのSheet3に Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next For Each c In Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)) If c.Offset(0, 1).Value = "◯" Then '↓(2).xlsmのSheet2に Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value Else '↓(2).xlsmのSheet3に Sheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next End Sub ご指導頂ければ幸いです。

  • エクセルVBA の変数を使うべきでしょうか?

    はじめまして。エクセル初心者です。 書籍やサイトで勉強させてもらっていますが、VBAがなかなか難しくてすぐに壁にぶつかってしまいます。少々困ってしまい、詳しい方のアドバイスを頂ければと質問を投稿させていただきました。 どうか宜しくお願い致します。質問ですが、 以下のようなコードで、sheet5のB列の任意のセルをダブルクリックした場合、sheet5のBCD列の同じ行のセル値がsheet1の指定した列に入力されるという処理を作りました。 これで一応目的の動作はするのですが、数が増えると「コンパイルエラー・プロシージャが大きすぎます」というメッセージがでてしまいます。列や行には規則性があるので、もしかしたら変数というものを使ってコードを書き直せばいいのかなと思いネットで調べてみたのですが、今のところさっぱり理解できません。 申し訳ありませんが、分かりやすくご教授いただけないでしょうか。バージョンは2003を使っています。 また、下のコードですと、sheet5のBCDいずれかのセルに空白があった場合、sheet1の列に入力されるときに入力される行がずれてしまいます。今は空白を何かで埋めて対処しているのですが、この問題の解決策も教えて頂けると助かります。どうか宜しくお願い致します。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, cancel As Boolean) If Target.Address = "$B$2" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B2") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C2") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D2") Worksheets("sheet1").Activate cancel = True End If If Target.Address = "$B$3" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B3") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C3") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D3") Worksheets("sheet1").Activate cancel = True End If If Target.Address = "$B$4" Then Worksheets("sheet1").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Target.Value Worksheets("sheet1").Range("H" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("B4") Worksheets("sheet1").Range("K" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("C4") Worksheets("sheet1").Range("M" & Rows.Count).End(xlUp).Offset(1).Value = Worksheets("sheet5").Range("D4") Worksheets("sheet1").Activate cancel = True End If   ・     ・   ・     ・   ・     ・ End Sub