• 締切済み

可視セルだけを選択対象にしたい

I列の6行目~最終行までをキーにして、別ファイルにセルの値をコピペするコードを作りました Sub test() Dim wb(1 To 2) As Workbook Dim II As Long, pt As String With Application Set wb(1) = .Workbooks("A.xls") Set wb(2) = .Workbooks("B.xls") pt = wb(2).Path If Right(pt, 1) <> .PathSeparator Then pt = pt &.PathSeparator End With II = 6 Do With wb(1).Worksheets("Sheet1").Cells(II, "I") If .Value = "" Then Exit Do wb(2).Worksheets("Sheet1").Range("A1").Value = .Value wb(2).Worksheets("Sheet1").Range("A2").Value =.Offset(0, 1).Value wb(2).SaveAs pt & .Value & ".xls" End With II = II + 1 Loop wb(2).Close Erase wb End Sub 始まりはI列の6行目からなのですが、フィルタをかけるため行番号が飛び飛びになり、上記コードでは思った答えが出ません フィルタをかけた後の可視セルの状態で上記コードを動かしたいのですが、 うまく修正ができません・・・ どなたかご教授いただけますでしょうか よろしくお願い致します

みんなの回答

  • merlionXX
  • ベストアンサー率48% (1930/4007)
回答No.1

With wb(1).Worksheets("Sheet1").Cells(II, "I") If .EntireRow.Hidden = False Then '追加(可視行だったら) If .Value = "" Then Exit Do ためしてませんけど・・。

関連するQ&A

  • ブック内に特定名のシートがある場合

    はじめまして、こんにちは。 VBAを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub

  • セルの値でなくセルの関数を参照したい

    次のコードでセルI13の値を入力できましたが、 '---------------------- 'Dim i As Integer 'For i = 2 To Worksheets.Count - 6 'With Worksheets(i) '.Range("I13") = Worksheets(1).Range("I13").Value 'End With 'Next セルの値でなく関数を入力しようとして次のコードに修正したらエラーになりました。どこがいけないのでしょうか。 Dim i As Integer For i = 2 To Worksheets.Count - 6 With Worksheets(i) .Range("I13").Formula = "=" & Worksheets(1).Name & "!I13" End With Next

  • VBA 実行時エラーで、"プロパティまたはメソッド

    ・Sheet1(コード) Private Sub CommandButton1_Click() Call aaa End Sub ・Module1(コード) Sub aaa() Dim wb As Workbook Dim ws As Worksheet Workbooks.Open ("c:\test.xls") Set wb = Workbooks("test.xls") Set ws = wb.Worksheets("Sheet1") wb.ws.Range("A2").Value = "CCC" End Sub wb.ws.Range("A2").Value = "CCC"の部分で 以下の実行エラーが出ます。 ------------------------------------------------------------------------ 実行時エラー'438': オブジェクトは、このプロパティまたはメソッドをサポートしていません。 ------------------------------------------------------------------------ Set wb = Workbooks("test.xls") Set ws = wb.Worksheets("Sheet1") の部分で特にエラーも出ないので、オブジェクトの取得は成功していると 思うのですが、WorkSheetオブジェクトのwsからRangeメソッドを呼ぶことが できません。 動かない原因と対策を教えてください!!

  • 指定セルを別ブックへ貼り付ける作業

    1.現在、見積書.xlsの見積汎用シートで以下の内容で同じブックのデータベース貼付シートに貼り付けています。 Sub データベース貼付() GYOU = Worksheets("データベース").Range("A65536").End(xlUp).Row + 1 Worksheets("データベース").Cells(GYOU, 1).Value = Range("H13").Value Worksheets("データベース").Cells(GYOU, 2).Value = Range("C8").Value Worksheets("データベース").Cells(GYOU, 3).Value = Range("C6").Value Worksheets("データベース").Cells(GYOU, 4).Value = Range("C15").Value Worksheets("データベース").Cells(GYOU, 5).Value = Range("D15").Value Worksheets("データベース").Cells(GYOU, 6).Value = Range("E15").Value Worksheets("データベース").Cells(GYOU, 7).Value = Range("G30").Value Worksheets("データベース").Cells(GYOU, 8).Value = Range("H1").Value 2.これを見積書.xlsの見積汎用シートを別ブックのデータベース.xlsのデータシートに貼り付けたいと思います。 3.以下の内容で仮に自分で貼り付けてみようとしましたがうまくいきません。 Sub コピーしてすべて貼り付ける() Workbooks("見積書.xls").Worksheets("見積汎用").Range(D6).Copy _ Workbooks("データベース.xls").Worksheets("データ").Range(B4) End Sub どのように、別ブックに指定したセルを貼り付けできるでしょうか?いろいろとサイトを見ましたがどうもうまくできませんでした。 説明がわかりづらく申し訳ないですが、どなたか教えていただけないでしょうか? よろしくお願い致します。

  • このコードの修正を、何卒よろしくお願い致します。

    EXEL 2002 です。 下記コードの修正を、何卒よろしくお願い致します。 ------ Sub コピー() Dim i As Integer For i = 1 To 2 Workbooks("コピー元.xls").Activate Worksheets(i).Range("A1", Range("C65536").End(xlUp).Offset(0, 168)).Copy _ Destination:=Workbooks("コピー先.xls").Worksheets(Workbooks("コピー先.xls").Sheets(1).Range("A1")) Next i End Sub

  • 「 VBA の 宣言 」 がない場合の問題点は ?

    下記例で、 「 宣言 」 なしでも、現在のところ、問題は発生してませんが、 今後、「 宣言 」 がなかった場合の 「 問題点の例 」 を教えて下さいませ。 ------------------------------- Sub ブックA*の全シートをコピー() Dim Wb As Workbook '宣言 For Each Wb In Workbooks If Wb.Name Like "ブックA*.xls" Then With Workbooks("ブックB.xls") Wb.Worksheets _ .Copy after:=.Sheets(.Sheets.Count) End With End If Next Worksheets(Worksheets.Count).Activate MsgBox ActiveSheet.Index Worksheets("Sheet1").Select End Sub

  • 他Bookへの抽出

    お世話になります。 開いているBook1からデータを抽出し、Book2へコピーしたいのですが、AdvancedFilterでエラーが出てしまいます。 何がまずいのかよくわかりません。 お分かりになる方、ご教授願います。 Private Sub Worksheet_Activate() Set myTbl = Workbooks("Book1.xls").Worksheets("Sheet1").Range("myTbl") Set myQry = Workbooks("Book2.xls").Worksheets("抽出条件").Range("A_抽出条件") Set sakiRng = Workbooks("Book2.xls").Worksheets("A").Range("A3:AR3") myTbl.AdvancedFilter xlFilterCopy, myQry, sakiRng ←ここでエラーになります。 Dim rw As Long '入力最終行 rw = Range("I65536").End(xlUp).Row With Application Range("I" & rw + 1) = .Sum(Range("I1:I" & rw)) Range("AO" & rw + 1) = .SumIf(Range("AP1:AP" & rw), "済", Range("AO1:AO" & rw)) Range("AQ" & rw + 1) = .Sum(Range("AQ1:AQ" & rw)) End With End Sub

  • VBAでご相談です!

    Excel2010使用。 VBA初心者です。 VBAでご相談させて下さい。 複数のファイルを1つにまとめる 作業をしたいと思い、ググったところ あるサイトで下記のコードを見つけました。 ただ、このコードでは、ファイルをダイアログから 選択する形になります。 これを、ファイルを指定した状態で実行させたいと思い、 自分で試してみたのですが、上手くいきませんでした。 同一フォルダ内には4つのファイルがあり、全て同じ様式の シートが複数あります。ただ、フォルダ名が毎月変更になります。 この同一フォルダ内のデータの中の特定のシートを一つのシートに まとめたいと考えているのですが、可能でしょうか? 可能であれば、アドバイスいただけるとありがたいです。 Sub sample() Dim myPath As String Dim wb_A As Workbook, wb_B As Workbook Dim i As Long, s As Long myPath = Application.GetOpenFilename(("Excel ファイル (*.xls), *.xls"), , "データを蓄積するブックを選択して下さい。") If myPath = "False" Then Exit Sub Set wb_A = Workbooks.Open(myPath) myPath = Application.GetOpenFilename(("Excel ファイル (*.xls), *.xls"), , "データを取得するブックを選択して下さい。") If myPath = "False" Then Exit Sub Set wb_B = Workbooks.Open(myPath) With wb_B For i = 1 To .Worksheets.Count 'wb_Bループ For s = 1 To wb_A.Worksheets.Count 'wb_Aループ '同じ名前のシートがあるとき データコピー If .Worksheets(i).Name = wb_A.Worksheets(s).Name Then .Worksheets(i).Range("A1").CurrentRegion.Copy _ wb_A.Worksheets(i).Range("A65536").End(xlUp).Offset(1) Exit For End If '同じ名前のシートが無いとき シートコピー If s = wb_A.Worksheets.Count Then .Worksheets(i).Copy Before:=wb_A.Sheets(1) End If Next s Next i wb_B.Close False MsgBox "完了" End With End Sub ※長文、説明下手で申し訳ありませんが よろしくお願いします。 <参考URL>   http://www.excel.studio-kazu.jp/kw/20040709212700.html

  • 最終セルまでデータを反映させるマクロ

    あるサイトからの利用コードです。 それをアレンジしようとしましたが、つまずきました。 マクロコードをご教示ください。 あるフォルダに複数のエクセルファイルがあります。 構成が同じシート(名前は同じ。仮に "各シート")を、 別ブック(仮に "まとめ")の一つのシートに纏めます。 その時、複数ファイルの D4のデータだけは "まとめ"ブックのL列に反映させたいのですが、 下記コードを使用すると、どこにどのようなコードを入れたら良いのでしょうか? 因みに複数ファイルの8行目からコピーされ、 複数ファイルのCからM列は まとめブックのAからK列に反映されるようになってます。 (まとめブックの1行目は見出し) Dim i As Integer Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long Set WS2 = Sheets("まとめ") strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Sheets("各シート") With WS1.Range("C7") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 11).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With _____ここで つまずく_____    With WS1.Range("D4")     .Copy WS2.Range("L" & WS2.Rows.Count).End(xlUp).Offset(1)     WS2.Range("L" & WS2.Rows.Count).End(xlUp).AutoFill Destination = Range("E1048576").End(xlUp).Row _____ここまで つまずく_____ WB1.Close False End If strFileName = Dir Loop End Sub エクセル2013です。 宜しくお願い致します。

  • 2つのブックで、1レコードの2列の値が同じ行のセル選択するには?

    2つのブックで、1レコードの2列の値が同じ行のセル選択するには? Windows XP Home Edition Office XP Personal 2002 Excel 2002 画像のように、左.xls 右.xls 共に、 1レコードの 「 B列 と C列 」 の値が同じ行のセルを選択したいのですが、 うまく行きません。 画像の例では赤色セルの部分です。 左右のブックの赤色セルの各行番号は同じではありません。 B列(日付、実際には西暦です)だけは、全く同じデータとなっております。 ●2つのブックを左右に並べて、  同じ行データを閲覧したいわけでございます。 何卒、ご教示のほどをお願い致します。 Sub TEST() Const wBook = "右.xls" '表示させたいBook名 Const wSht = "Sheet1" '表示させたいSheet名 Dim Target As Range Dim TargetVa As Integer TargetVa = ActiveWindow.ActiveCell.Value With Workbooks(wBook).Sheets(wSht)   For Each Target In .Range("B1", .Range("B65536").End(xlUp))    If Target.Value = TargetVa Then     Workbooks(wBook).Activate     Sheets(wSht).Activate     Target.Cells.Select    End If   Next Target  End With End Sub

専門家に質問してみよう