• 締切済み

excelデータベースによる差込印刷について質問です。

新しい職場で使用されているデータベースがあるのですが、オートフィルタによる絞り込み後のデータのみ(可視セルのみ)の差込印刷ができなくて困っています。 データベースは「date.xls」ファイルに各データが格納され、「入力及び印刷.xls」ファイルのコマンドボタンにて入力・プリントアウトを行っています。 現状でも印刷ボタンはあるのですが、オートフィルタされたデータの一番上から一番下までのデータが全て印刷されてしまうようです(不可視セルも含めて) 以下に関係してそうなコードを記載します。 【印刷】 Private Sub CommandButton3_Click() '印刷 Dim Msg Dim i As Long, k As Long, eflag As Long UserForm1.Hide If StartData = 0 Or SaisyuData = 0 Then Exit Sub ' エラーが発生したら、エラー メッセージを作成 On Error Resume Next ' エラーのトラップを留保 Fukusya (StartData) ActiveWindow.SelectedSheets.PrintPreview 'commandpos If MsgBox("選択" & RowCount & "件 だけ印刷 ", vbOKCancel) <> vbCancel Then For i = StartData To SaisyuData Fukusya (i) ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ActiveWindow.View = xlNormalView ' エラーの発生をチェックした後、メッセージを表示 If Err.Number <> 0 Then Msg = "エラー番号 " & Str(Err.Number) & Err.Source & " でエラーが発生" & Chr(13) & Err.Description MsgBox Msg, , "エラー", Err.HelpFile, Err.HelpContext End If Next 'commandpos End If Fukusya (SaisyuData) Calculate End Sub 【印刷コード内の各単語に関するもの】 Private Function StartData() Dim i As Long, k As Long, eflag As Long Dim start As Long k = Retu start = 0 For i = 3 To k If Workbooks("data.xls").Worksheets("data").Rows(i).Hidden = False Then start = i Exit For End If Next StartData = start End Function Private Function SaisyuData() Dim i As Long, k As Long, eflag As Long Dim stp As Long k = Retu stp = 0 For i = k To 3 Step -1 If Workbooks("data.xls").Worksheets("data").Rows(i).Hidden = False Then stp = i Exit For End If Next SaisyuData = stp End Function Private Sub Fukusya(mm As Long) 'data複写 Dim i As Long, j As Long, k As Long Dim nn As String nn = RowCount UserForm1.TextBox1.Value = nn UserForm1.TextBox4.Value = TourokuSoSu - 2 UserForm1.TextBox5.Value = Myretu - 2 k = Koumokusu j = mm 'データシートから配列に読み込み With Workbooks("data.xls").Worksheets("data") For i = 0 To k kou(3, i) = .Cells(j, i + 1).Value Next GazoSize(0) = .Cells(j, k + 3).Value GazoName(0) = .Cells(j, k + 2).Value GazoSize(1) = .Cells(j, k + 5).Value GazoName(1) = .Cells(j, k + 4).Value End With '配列からフォームに読み込み With Worksheets("入力") For i = 0 To k If kou(1, i) = "" Then Exit For .Range(kou(1, i)).Value = kou(3, i) Next End With image1 image2 End Sub 長くなって申し訳ありません。以上のようなコードになっています。 なんとか「date.xls」上で絞り込んだ可視セルのみを、「入力及び印刷.xls」ファイルに差し込んで印刷したいです。よろしくお願いいたします。

みんなの回答

noname#192382
noname#192382
回答No.1

絞込みをしたデータを別の名前をつけて保存をして、差込には新しく保存したデータを使うようにすればよいのではないですか。 ここに示してあるマクロの中に絞込みのところが含まれているのか私はわからなくて申し訳ありません。

koonbat
質問者

お礼

ありがとうございます。 「date.xls」ファイルと「入力及び印刷.xls」は連動していて、 「date.xls」というファイル名でないと「入力及び印刷.xls」は データを認識できない仕様のようです。 つまり、新しいファイル名にしてしまうと差込印刷ができません。

関連するQ&A

  • excelのVBAでアドバイスお願いします

    excel2000を利用しています。 ■状況 ・「実験フォルダ」という名前のフォルダがあります ・「実験フォルダ」の中に「差し込み表示.xls」という名前のファイルがあります ・「実験フォルダ」の中に「実験データ.xls」という名前のファイルがあります。 ■やりたいこと ・「実験データ.xls」のファイルデータを参照して、「差し込み表示.xls」のファイルにデータを表示させたい。 ・検索するキーは日付(「実験データはB列、差し込み表示はE5セル」です。 ■状況 自分で作ったコードだと値がみつかりません、となって、うまくデータを転記して表示してくれません。 ■お願いしたいこと コードの修正アドバイス、もしくは、他にもっといいプログラムがあるなどのアドバイスがあればいただけるとありがたいです。 ■うまくいかないコード Option Explicit Sub datatyuusyutu() On Error Resume Next Const sashikomiDisplay As String = "差し込み表示.xls" Const dataFile As String = "実験データ.xls" Dim i As Long Dim j As Long Dim k As Long Dim objectionrow As Long Dim lastRow As Long Dim targetDate As String Dim targetTime As String Dim data(1 To 43) As Double Dim dataFindFlag As Boolean Dim 対象フォルダ As String '検索する年月日を取得 targetDate = Range("E5").Value MsgBox targetDate 対象フォルダ = ThisWorkbook.Path & "\" Workbooks.Open 対象フォルダ & dataFile lastRow = Cells(Rows.Count, "B").End(xlUp).Row 'B列の最終行を得る MsgBox lastRow '年月日で検索 For i = 2 To lastRow If Cells(i, 2) = targetDate Then Cells(i, 2).Select dataFindFlag = True For k = 1 To 43 data(k) = Cells(i - 1, k) Next k Exit For End If Exit For Next i Windows(sashikomiDisplay).Activate With Workbooks("実験データ.xls") If dataFindFlag = True Then Cells(1, 2) = data(1) Cells(12, 3) = data(4) Cells(14, 6) = data(5) MsgBox "実行しました" Else MsgBox "データがありません" End If End With Workbooks(dataFile).Close savechanges:=False End Sub

  • comboboxで任意の行列を削除する

    comboboxで選択したデーターを探して、その行の 2列目から45列までを、削除する方法をお教えください。 下のように記述したのですが、1行全てが削除されてしまいます。 どのように記述したらよいのでしょうか。 よろしくお願いします。 Private Sub 保存データー削除_Click() Dim i As Long For i = 2 To 199 If Cells(i, 2).Value = combobox1.Value Then Range(i & ":" & i).Delete End If Next i Dim k As Long, s As Long k = 1 For s = 1 To 31 Cells(s, 1).Value = k k = k + 1 Next s End Sub

  • Excel VBA 複数シートの一括印刷について

    標記の件、御指導願います。 シート1:印刷設定(チェックボックスが印刷したいシート分あります) シート2~34:チェックボックスがオンである表題のシートを選択し一括で印刷する。 を、VBAで作ってみましたが、エラー(インデックスが有効範囲にありません)が出てしまいます。 Sub CheckBoxPrint() Dim ArrySheet() As String Dim I As Long Dim k As Long k = 0 For I = 1 To 33 If ActiveSheet.OLEObjects("CheckBox" & I).Object.Value = True Then ReDim Preserve ArrySheet(k) ArrySheet(k) = ActiveSheet.DrawingObjects("CheckBox" & I).Object.Caption k = k + 1 End If Next I ThisWorkbook.Worksheets(ArrySheet).PrintOut ←エラー(インデックスが有効範囲にありません) Erase ArrySheet End Sub     このエラーを回避する方法を御指導してください。 よろしくお願い致します。

  • エクセルVBAでPDFを1枚目のみ印刷したい

    下記のVBAに複数PDFが重なっている場合は、一枚目のみ印刷する文面を 挿入したいのですがうまくいきません Sub Test() Dim z As Object Dim i As Long Dim f, p As String Application.ScreenUpdating = False Set z = CreateObject("WScript.Shell") p = Application.ActivePrinter For i = 1 To Range("A1").End(xlDown).Row f = "h:\hozei\" & Cells(i, 1).Value & ".pdf" If Dir(f) <> "" Then z.Run ("AcroRd32.exe /t " & f) Else Cells(i, 2).Value = Cells(i, 1).Value Cells(i, 1).Value = "" End If Next i Set z = Nothing End Sub お忙しいところ申し訳ございません どなたかご教示願います。

  • エクセルVBAのイベントで質問です。

    ダブルクリックイベントで、G12:G31の範囲の文字列をB10:B27の範囲(最下行)に入れていくものを使っていますが、新たにH12:H31にある文字列もダブルクリックするとC10:C27の範囲(最下行)に入れていけるようにしたいと思います。 どのようにすればいいでしょうか。 ご存知の方いらっしゃればお教えいただけると助かります。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Dim i As Long Dim flg As Boolean If Intersect(Target, Range("G12:G31")) Is Nothing Then Exit Sub If IsEmpty(Target.Value) Then Exit Sub With Worksheets("シートA") For i = 10 To 27 If .Range("B" & i).Value = "" Then .Range("B" & i).Value = Target.Value flg = True Exit For End If Next i If flg = False Then MsgBox .Name & " がいっぱいです。" End If End With Cancel = True End Sub

  • 下記のマクロをもっと早くするには?

    下記のマクロは、 A列にあるURLがSSL化(https)されているかを調べるものです。 このマクロを動かすと、大体3秒に1つのURLを調べるくらいの早さです。 もっと早く調べられるようにするには、どのような記述にすればできるでしょうか? また、エクセルの他の設定で、マクロを早くできたりしますか? よろしくお願いいたします。 Sub SSL() Dim objHttp As Object Dim nURL As String Dim strURL As String Dim i As Long, f As String, l As String Dim Lastrow As Long, getLine As Long Set objHttp = CreateObject("WinHttp.WinHttpRequest.5.1") On Error GoTo ErrHandler 'A1から getLine = Cells(Rows.Count, 2).End(xlUp).Row Lastrow = Cells(Rows.Count, 1).End(xlUp).Row If getLine = Lastrow Then MsgBox "既に終わっているか、データがないです。", vbExclamation: Exit Sub If getLine < Lastrow And Cells(1, 2).Value <> "" Then getLine = getLine + 1 Else getLine = 1 '最初の行が1行目からの場合 End If For i = getLine To Lastrow strURL = LCase(Trim(Cells(i, 1).Value)) 'A列の登録URL strURL = Replace(strURL, "https:", "http:") If strURL Like "http*" Then objHttp.Open "GET", strURL, False objHttp.send DoEvents 'ESC割り込み可能にする With objHttp If .Status = 200 Then nURL = .Option(1) 'WinHttpRequestOption_URL f = Mid(strURL, 1, InStr(strURL, "://")) l = Mid(nURL, 1, InStr(nURL, "://")) If nURL = "" Then Cells(i, 2).Value = "no URL" ElseIf nURL <> "" Then If LCase(f) = LCase(l) Then Cells(i, 2).Value = "non SSL" Else Cells(i, 2).Value = "https" End If End If Else Cells(i, 2).Value = "Err:" & .Status End If End With End If Endline: nURL = "" strURL = "" Next i MsgBox "Finished" Exit Sub ErrHandler: If Err() <> 0 Then Cells(i, 2).Value = Err.Number 'マイナスになるのは外部エラー GoTo Endline End If End Sub

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.(5,2)がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)  ← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • 連続データのVBAの質問

    お世話になります。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Range("C1") <= Date - Day(Date) Then Exit Sub If Not Intersect(Target, Range("C1,B9:B39")) Is Nothing And Target.Count = 1 Then Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True ElseIf Not Intersect(Target, Range("R8:R38")) Is Nothing Then Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End If End Sub これはセルC1に年月を表記させ、そのC1セルの年月を変更した場合B9~B39のセルが自動で連続データの数字を記入し、B9~B39のどこかのセルを空白にすると、そのセル以降も空白になります。 そこで質問ですが、例えばB14の数字を消すとB15~39まで空白のセルになります。そして、B20に1と入力するとB21~39に連続データの数字が自動記入されます。 そしてC1の年月を次の月に更新した際は、B39で示された数字以降の連続データをB9に表示させるには、どうすれば良いでしょうか?

  • エクセルで連続印刷した範囲を印刷済とわかるように

    エクセルで以下のようなプログラムで変数s、eに入力の範囲でシートの連続印刷しております。印刷し終わった後ですが、変数s~eの範囲を赤くして印刷済かどうかをひと目でわかるようにしたいと思います。可能でしょうか。 Sub 範囲を指定して印刷() Dim s As Long Dim e As Long Dim i As Long On Error Resume Next s = InputBox("開始No.を入力して下さい。") If s = 0 Then Exit Sub e = InputBox("終了No.を入力して下さい。") If e = 0 Then Exit Sub For i = s To e Worksheets("A").Range("C1") = i Application.Wait Now + TimeSerial(0, 0, 10) Worksheets("B").PrintOut Next i End Sub

  • エクセルの質問です。

    エクセル マクロについて質問です。 現在,以下のような記述をエクセル上のボタンに登録しています。 ボタンを押すと,デスクトップ上の任意のCSVファイルの選択を行い,CSVファイルを選択し,そのCSVデータを全てエクセル上のデータとして落としさせたいと思っています。 しかし,csvファイルによっては, 「実行時エラー  アプリケーション定義またはオブジェクト定義のエラーです。」と出て, 「デバック(D)」ボタンを押すと,下から4行目の 「Cells(i, j) = strCell」のところが,黄色くエラーとして表示されてしまいます。 下記の記述もネット上で皆さんに教えていただきながらなんとかやっているもので,正直自分自身でよく理解できていませんが,上記のようなエラーを回避する方法をどなたかご教示いただけないかと思います。 どうかよろしくお願いいたします。 Sub Macro5() Dim varFileName As Variant Dim intFree As Integer Dim strRec As String Dim strSplit() As String Dim i As Long, j As Long, k As Long Dim lngQuate As Long Dim strCell As String varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _ Title:="CSVファイルの選択") If varFileName = False Then Exit Sub End If intFree = FreeFile '空番号を取得 Open varFileName For Input As #intFree 'CSVファィルをオープン i = 0 Do Until EOF(intFree) Line Input #intFree, strRec '1行読み込み i = i + 1 j = 0 lngQuate = 0 strCell = "" For k = 1 To Len(strRec) Select Case Mid(strRec, k, 1) Case "," '「"」が偶数なら区切り、奇数ならただの文字 If lngQuate Mod 2 = 0 Then Call PutCell(i, j, strCell, lngQuate) Else strCell = strCell & Mid(strRec, k, 1) End If Case """" '「"」のカウントをとる lngQuate = lngQuate + 1 strCell = strCell & Mid(strRec, k, 1) Case Else strCell = strCell & Mid(strRec, k, 1) End Select Next '最終列の処理 Call PutCell(i, j, strCell, lngQuate) Loop Close #intFree End Sub Sub PutCell(ByRef i As Long, ByRef j As Long, ByRef strCell As String, ByRef lngQuate As Long) j = j + 1 '「""」を「"」で置換 strCell = Replace(strCell, """""", """") '前後の「"」を削除 If Left(strCell, 1) = """" And Right(strCell, 1) = """" Then strCell = Mid(strCell, 2, Len(strCell) - 2) End If Cells(i, j) = strCell strCell = "" lngQuate = 0 End Sub

専門家に質問してみよう