• 締切済み
  • すぐに回答を!

エクセルマクロで教えてください

Sub smp05_14_01() Dim 対象セル As Range Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim 行 As Long, 列 As Long Dim i As Long Set ws1 = Worksheets("顧客") Set ws2 = Worksheets("売上") Set ws3 = Worksheets("顧客未登録") 行 = ws1.Range("A1").End(xlDown).Row - 1 列 = ws1.Range("A1").End(xlToRight).Column Set 対象セル = ws1.Cells(1, 列 + 2).Resize(2, 行) For i = 1 To 行 対象セル(1, i).Value = "顧客NO" 対象セル(2, i).Value = "<>" & ws1.Cells(i + 1, 1) Next ws2.Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=対象セル, _ CopyToRange:=ws3.Range("A1") 対象セル.Clear End Sub 上記のマクロは売上のシートに登録されている以外の顧客NOを顧客シートを参照して顧客未登録シートにコピーするのもですが添付したファイルの数だと上手くいくのですが、エクセルのヨコのセルの最大値の258を越えると上手くいきません。上記の処理で1000レコードを越えても売上シートに登録されている以外の顧客NOを参照して顧客未登録シートにコピーするマクロを教えてください。

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

  • 回答数2
  • 閲覧数128
  • ありがとう数2

みんなの回答

  • 回答No.2
  • Wendy02
  • ベストアンサー率57% (3570/6232)

こんばんは。 ご質問に出ているマクロは、本当にうまく行っているのですね? >売上シートに登録されている以外の顧客NOを参照して顧客未登録シートにコピーする 書かれていないようですが、売上データも含めるということだと思います。つまり、顧客未登録だけですと、ダブりをはじき出さないといけないと思うのです。コードを見る限りは、それを含めているように読めます。もし、後者のほうですと、コードは違うものになります。 それと、おそらくは、ある程度決まったデータ範囲でしょうから、データサンプルがあると回答が付けやすかったです。 '------------------------------------------- Sub PickUpNonResistCustomer()   Dim ws1 As Worksheet   Dim ws2 As Worksheet   Dim ws3 As Worksheet   Dim CustomerNos As Variant   Dim ret As Variant   Dim col As Long   Dim i As Long      Set ws1 = Worksheets("顧客")   Set ws2 = Worksheets("売上")   Set ws3 = Worksheets("顧客未登録")      With ws1     CustomerNos = .Range("A2", .Range("A65536").End(xlUp))   End With   CustomerNos = Application.Transpose(CustomerNos)      With ws2     Application.DisplayAlerts = False     col = .Range("IV1").End(xlToLeft).Column + 1     For i = 2 To .Range("A65536").End(xlUp).Row       ret = Application.Match(.Cells(i, 1).Value, CustomerNos, 0)       If IsError(ret) Then         .Cells(i, col).Value = 1       End If     Next     .Range("A1").CurrentRegion.AutoFilter _     field:=col, _     Criteria1:="1"     Application.DisplayAlerts = True     With .AutoFilter.Range       .Resize(, .Columns.Count - 1).Copy ws3.Range("A1")       .Range("A1").AutoFilter       .Columns(col).ClearContents     End With   End With End Sub '------------------------------------------- なお、ここで、Transpose 関数は使っていますが、2002以上なら、1万個でも可能です。ただし、Transpose は、最初は、配列を1次元にするために用いています。

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

関連するQ&A

  • エクセルでのマクロを使った参照

    教えてください。 シート1のB23:F73のデータをシート2に張りつけたいのですが、 その際にB列には連番で1~50の数字が入っており C、D列にはデータが有る場合とない場合があります。 データがある場合は必ず対で存在します。 貼り付けの際にC、D列にデータのある行のみ B、C、D列のデータを連続で並ばせたいのですが、 どのようにマクロを組んだらよろしいですか? 手元に資料もなく、困ってしまいました。 よろしくお願いします。 現在のマクロは以下の通りです Sub TEST4() Dim S1 As Worksheet, S2 As Worksheet Set S1 = Worksheets("SHEET1") Set S2 = Worksheets("SHEET1") S2.Range("A1:E51").Value = S1.Range("B23:F73").Value End Sub

  • エクセルのマクロについて

    下記のようなプログラム組んでいます。 Sub 張付() Sheets("一覧表").Select Dim i As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("一覧表") Set ws2 = Worksheets("データー") For i = 5 To ws2.Cells(Rows.Count, 1).End(xlUp).Row ws1.Range("B5") = ws2.Cells(i, 2)    'セルB5に氏名を入力 ws1.Range("C5") = ws2.Cells(i, 3)    'セルC5に年齢を入力 ws1.Range("D5") = ws2.Cells(i, 4)    'セルD5に電話番号を入力 この後、 ws1.Range("B5")のB5をB6にまた、C5はC6に改行してそれぞれデーターを移していきたい のですが、B5をB6に順次プラスする方法を教えて下さい。 よろしくお願いいたします。

  • Excel マクロの一部改造の方法を教えて下さい。

    先日、tom04さんから下記のマクロを教えていただきました。 sheet1のセルA1にsheet2のセルA1からA??までの項目を順次入れ、sheet1を印刷するものです。 これに、追加でsheet1のセルB1にも項目を追加したいのです、データーはsheet2のB1から入れておくこととします。 下記のマクロを教えて下さった、tom04さんの目にとまれば幸いですが、内容を理解して頂いた方ならどなたでも回答頂ければ幸いです。よろしくお願い致します。 改造して頂きたいマクロは下記です。 Sub test() 'この行から Dim i As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("sheet1") '←Sheet名は適宜変更してください Set ws2 = Worksheets("sheet2") '←こちらのSheet名も適宜変更 For i = 1 To ws2.Cells(Rows.Count, 1).End(xlUp).Row ws1.Range("A1") = ws2.Cells(i, 1) '←Sheet1のA1セルに名前を表示 ws1.PrintOut Next i End Sub 'この行まで

  • 回答No.1

どこかの書籍かWebサイトのサンプルでしょうか?フィルタオプションのand条件を、行方向にずらずらと並べていくという、それほど沢山の条件に対応するつもりのない、コードだと思います。 「改造は無理なので(2007なら動くかも)、Accessに移行してクエリを使うと良いでしょう」と言ってしまうと、身も蓋もないので、こしらえてみました。シート内の列配置等が明確でないので、簡略化したモデルで試しておりますので、勘違いもあるかもしれません。最近「高速化」について、色々試しておりましたので、全て一旦配列に取り込んでから処理し、ワークシートに書き戻しています。と、言うことで分かりやすいコードではありません。興味を持たれたらお勉強してください。分かりやすいやり方だと、データ数が増えた場合、イラっとする程度待たされると思います。 Sub test() Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim myRowCount As Long, myColumnCount As Long Dim i As Long, j As Long, counter As Long Dim customerList As Variant Dim salesData As Variant Dim myDic As Object Dim myKey As String Dim unRegistered() As Variant, unRegistered2() As Variant Set myDic = CreateObject("Scripting.Dictionary") Set ws1 = Worksheets("顧客") Set ws2 = Worksheets("売上") Set ws3 = Worksheets("未登録") myRowCount = ws1.Range("A1").End(xlDown).Row myColumnCount = ws1.Range("A1").End(xlToRight).Column customerList = ws1.Range(ws1.Cells(2, 1), ws1.Cells(myRowCount, myColumnCount)) myRowCount = ws2.Range("A1").End(xlDown).Row myColumnCount = ws2.Range("A1").End(xlToRight).Column salesData = ws2.Range(ws2.Cells(2, 1), ws2.Cells(myRowCount, myColumnCount)) '顧客コードリストをdictionary(連想配列)に読込 For j = 1 To UBound(customerList, 1) myKey = CStr(customerList(j, 1)) If Not myDic.exists(myKey) Then myDic.Add myKey, "" Next j counter = 0 '売上データの顧客コードをdictionaryと照合し、未登録データを配列に入れる For i = 1 To UBound(salesData, 1) myKey = CStr(salesData(i, 1)) If Not myDic.exists(myKey) Then counter = counter + 1 'Redim Preserveの都合上、縦横入れ替え ReDim Preserve unRegistered(1 To myColumnCount, 1 To counter) For j = 1 To UBound(salesData, 2) unRegistered(j, counter) = salesData(i, j) Next j End If Next i '配列の行、列入れ替え(Application.transpose関数はデータ数5461が最大らしいので) ReDim unRegistered2(1 To UBound(unRegistered, 2), 1 To UBound(unRegistered, 1)) For i = 1 To UBound(unRegistered, 1) For j = 1 To UBound(unRegistered, 2) unRegistered2(j, i) = unRegistered(i, j) Next j Next i 'ワークシートに貼り付け ws3.Range("A1").Resize(UBound(unRegistered, 2), UBound(unRegistered, 1)) = unRegistered2 End Sub

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

関連するQ&A

  • VBA マクロ シート 転記

    はじめまして。VBA初心者です。今シート1のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート2のB列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート2の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。 Sub 転記() Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range Dim LastRow As Long, i As Long, er As Long, wkey As String Set ws = Worksheets("Sheet1") Set ws1 = Worksheets("Sheet2") LastRow = ws.Range("A1").End(xlDown).Row er = ws1.Range("A1").End(xlDown).Row Set r = ws.Range("A1:A" & LastRow) For i = 1 To er wkey = ws1.Range("A" & i) Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole) If Not r1 Is Nothing Then ws1.Range("B" & i) = r1.Offset(, 1) End If Next Set r1 = Nothing Set r = Nothing Set ws = Nothing Set ws1 = Nothing End Sub どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか?宜しくお願いします。

  • エクセルの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の実行を制御することは可能でしょうか? 下のようなコードを作ったのですが、 Sub 承認書作成() Dim ws0 As Worksheet, ws1 As Worksheet, r1 As Range Dim i As Long Dim nyuryoku(), chikuseki() Set ws0 = Worksheets("承認書作成") Set ws1 = Worksheets("顧客データ") Set ws2 = Worksheets("業者コード") Set ws3 = Worksheets("承認通知書") Worksheets("顧客データ").Select Range("テーブル1[[#Headers],[NO.]]").Select Selection.End(xlToRight).Select Selection.End(xlDown).Select Selection.ListObject.ListRows.Add AlwaysInsert:=False Range("B7").Select nyuryoku = Array("b5", "d5", "f5", "h5", "j5", "l5", "n5", "p5", "b6", "d6", "f6", "h6", "j6", "l6", "n6", "p6", "b4", "d4") '転記したいセルの位置 chikuseki = Array("0", "1", "5", "6", "8", "9", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "53", "54") '転記先の列のオフセット値  Set r1 = ws1.Range("f" & Rows.Count).End(xlUp).Offset(0) 'データ蓄積セル  For i = 0 To UBound(nyuryoku) r1.Offset(0, chikuseki(i)).Value = ws0.Range(nyuryokui)).Value '入力 Next MsgBox "入力完了" Dim lRowNum As Long '転記先となる行番号を求める lRowNum = ws1.Cells(Rows.Count, "b").End(xlUp).Row '転記 ws3.Cells(6, "d").Value = ws1.Cells(lRowNum, "j").Value ws3.Cells(17, "g").Value = ws1.Cells(lRowNum, "c").Value ws3.Cells(22, "g").Value = ws1.Cells(lRowNum, "l").Value ws3.Cells(22, "ac").Value = ws1.Cells(lRowNum, "ab").Value    Set ws0 = Nothing   Set ws1 = Nothing End Sub ここに、     If call Macro1 then call 承認書作成  '上のマクロです    Else: Msgbox"中止" 「Macro1を実行しないと承認書作成マクロを実行できない」 という コードを組み込みたいのですが、うまくいきません。 VBA内に同じVBAを組み込むことは不可能なのでしょうか?

  • VBA転記について教えて下さい

    200件位のデータがあるとします。顧客情報AB・商品C&#65374;AY 氏名 性  青森りんご 長野りんご みかん バナナ 送料 AA  男   1             2      100 BB  女          1            100 CC  男                   3     0 このデータを別シートAにはりんごと送料 別シートBにはそれ以外のデータに分けたいのです。 シートA 氏名 性  青森りんご 長野りんご  送料 AA  男   1           100 BB  女        1    100 CC  男 シートB 氏名 性  みかん バナナ AA  男    2 BB  女 CC  男       3 こんな感じです。 色々参考にして作成しましたがうまくいきませんでしたので 教えて欲しいです。 よろしくお願いします。 エクセルは2002です。 1、項目名の転記でデータは200位ですが変動があるので最終行で作成したら うまくいきませんでした。 2、データ域の転記が動きません。 Sub サンプル() Dim i As Long Dim lastRow As Long Dim lastcolumns As Long Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet Dim myColumns As Long Dim myKey As String Set S1 = Worksheets("データ") Set S2 = Worksheets("りんご") Set S3 = Worksheets("その他") ' Sheet1の最終行を取得 lastRow = S1.Range("A" & Rows.Count).End(xlUp).Row ' Sheet1の最終列を取得 lastcolumns = S1.Cells(1, Columns.Count).End(xlToLeft).Column ' 項目名の転記 S2.Range("A1:B200").Value = _ S1.Range("A1:B200").Value S3.Range("A1:B200").Value = _ S1.Range("A1:B200").Value 'データ域の転記 For i = 2 To lastcolumns myKey = S1.Cells(1 & i).Value If myKey <> "" Then myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlUp).Columns + 1 S1.Range(S1.Cells(1, i), S1.Cells(lastRow, i)).Copy _ Worksheets(myKey).Range(Cells(1, myColumns), Cells(lastRow, myColumns)) End If Next i End Sub

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ(Sub チェック()以下です)に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です:  Sheet2のC列に 0  があれば  Sheet1のB列に 愛 と([太字]でセルの背景色を[灰色25%]にして)入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • Excelマクロについての質問です。

    Excelのマクロについての質問です。 マクロについての質問です。 以下のようなマクロを作成しました。 このマクロを動作させているのはこのマクロを作成したファイル上です。 Sub Macro9() Dim WBA As Workbook Dim WBB As Workbook Dim WSA As Worksheet Dim WSB As Worksheet Set WBA = Workbooks("A") Set WBB = Workbooks("B") Set WSB = WBB.Worksheets("1") For i = 100 To 3000 Step 20 Worksheets.Add Before:=Worksheets("Sheet1") Dim k As String k = i ActiveSheet.Name = (k / 100) Set WSA = WBA.Worksheets(k / 100) WSB.Range("A1:AY30").Copy Destination:=WSA.Range("A1") WSA.Range("D4:I30").Clear WSA.Range("Q4:V30").Clear WSA.Range("AD4:AI30").Clear WSA.Range("AQ4:AV30").Clear Next i Application.DisplayAlerts = False Sheets("Sheet1").Delete Application.DisplayAlerts = True Application.DisplayAlerts = False Sheets("Sheet2").Delete Application.DisplayAlerts = True Application.DisplayAlerts = False Sheets("Sheet3").Delete Application.DisplayAlerts = True End Sub そこで質問ですが、このマクロを作動させると何のエラーの表示もなく最後まで動作は完了します。 ですが、シートの作成は30まで作成できてもその後のセルのコピー&ペーストはなぜかシート6.8までしかできていません(7&#65374;30までのシートはシート作成はできているのですがコピペのみが実行されず空白のままになっています。) シートもコピペも両方ともシート30まで完了するにはどの点を改善すればいいのでしょうか? 知恵が足りずどうしても直す事が出来ません。 長文申し訳ございませんが是非皆さまのお知恵をお貸しください。 宜しくお願い致します。

  • ExcelのVBAについてです。シート1と2を作成

    ExcelのVBAについてです。シート1と2を作成し、シート1にバーコードまたはキーボードで入力します。シート1は入力専用かつ入力した分の早見表で、実際にはシート2に転記仕訳して、シート3以降に表を作成したいです。使い方はシート1に入力またはシート2をタップまたはクリックすると入力(画面)になります。以前の質問の回答を参考に必要最低限に改良しています。パッと見で構いません、何か不具合は見付からないでしょうか? '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Dim st1, s, i3 As Long Dim Bst As Range Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 st1 = ws1.Cells(Rows.Count, "E").End(xlUp).Row 'A列の最終行を設定する s = 3 For i3 = 3 To st1 Set Bst = ws2.Columns("E").Find(What:=ws1.Cells(i3, "E"), LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) シート間のE列を比較 If Bst Is Nothing Then '比較して無い場合は、下記を実行 ws1.Cells(s, "A") = ws1.Cells(i3, "A") '追加する文字を転記する。(コード) s = s + 1 End If Next i3 Next i '(1)シートを変数にセット Dim ws1_ As Worksheet Set ws1_ = Worksheets("Sheet1") ws1_.Activate End Sub

  • マクロ EXCELの範囲をコピーして貼付け

    『End(xlDown).Row』で取得した値を使ってセルの範囲指定&コピーを行い、 新しく追加したシートに貼り付けたいのですがうまくいきません。 Sub attendanceJoin() Dim MaxRow As Integer 'シートの最終行の値 Workbooks("test.xls").Activate Dim NewWorkSheet As Worksheet Set NewWorkSheet = Worksheets.Add() '新しいシートを追加する MaxRow = Worksheets(2).Range("M1").End(xlDown).Row  'A列の最終行を取得 NewWorkSheet.Name = "統合"  '新しく追加したシートの名前を変更 With Workbooks("test.xls") .Worksheets(2).Range("A1:M&MaxRow").Copy   'コピーするセルの範囲を指定    '↑ここでエラー。.Worksheets(2).Range("A1:M38").Copy を指定するイメージです。 .Worksheets("統合").Range("A1").PasteSpecial End With End Sub どなたか間違っている箇所のご教示お願い出来ますでしょうか。 どうぞよろしくお願い致します。

  • エクセル:マクロの手直し

    お世話になります。 以前ここで教えてもらったマクロのシート名のつけ方をすこし手直ししたいのでアドバイスください。 以下のマクロは、1シート目を決まった行数分に分割し各シートに振り分けるものです。今のマクロではシート名は分割1、分割2…分割10…などなりますが、Worksheets(1) のシート名+3桁の連番(001,002…010…)などとしたい。 Worksheets(1) のシート名が「総務課」の場合、総務課001,総務課002…総務課010…となるのが理想です。 このようにするためにはマクロをどのように修正すればよいか教えてください。 Sub シート分割()  Dim WS1 As Worksheet  Dim WS2 As Worksheet  Dim i As Integer  Dim Bunkatsu As Integer  Set WS1 = Worksheets(1) 'コピー元のデータシート  Set WS2 = WS1  Bunkatsu = 1  Application.ScreenUpdating = False  For i = 7 To WS1.Cells(Rows.Count, 1).End(xlUp).Row Step 25   Set WS2 = Worksheets.Add(After:=WS2)   WS2.Name = "分割" & Bunkatsu   WS1.Rows("1:6").Copy WS2.Cells(1, 1)   WS1.Rows(i & ":" & i + 24).Copy WS2.Cells(7, 1)   Bunkatsu = Bunkatsu + 1  Next  Application.ScreenUpdating = True End Sub

  • 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