複数シートの選択範囲を一枚のシートに貼り付ける方法
- Excel2007使用のマクロ初心者です。複数シートのセルB29からBQ60までのセル範囲を「計算シート」の一枚に右列方向に順次貼りつける方法を教えてください。
- 現在のコードでは不要な部分も貼り付けてしまっているため、セル範囲をB29からI60までとBM29からBM60までの2箇所を、「計算シート」に右列方向に貼り付けたいです。修正する方法や別の方法があれば教えてください。
- 修正方法としては、まず「計算シート」の一番右の列に作業用の列を追加しておきます。次に、ループを使って各シートの指定範囲をコピーし、作業用の列に順次貼り付けます。最後に、作業用の列から不要な部分を削除し、必要な部分だけを残すように修正します。別の方法としては、セル範囲を指定する方法ではなく、列や行の範囲を指定してコピーするという方法もあります。
- ベストアンサー
複数シートの選択範囲を一枚のシートに貼り付ける
Excel2007使用のマクロ初心者です。 以下のコードで正常に、動作しています。 複数シートのセルＢ29からＢＱ60までのセル範囲を 「計算シート」の一枚に右列方向に、順次貼りつけています。 しかしこれは不要な部分も貼り付けしてるので セル範囲をＢ29からＩ60までと ＢＭ29からＢＭ60までの２箇所を、上記同様に「計算シート」に 右列方向に貼りつけていきたいです。 このコードをどう修正したらよいでしょうか。また別方法ありますでしょうか。 Sub 計算表の一括複写() Application.ScreenUpdating = False Dim list, SheetName ActiveSheet.Unprotect Const EXCEPT_NAME = " 年月管理 最新明細 記録帳" Worksheets("計算").Activate Rows("2:33").Select Selection.Delete Shift:=xlUp Dim k As Long Dim ws As Worksheet Set ws = Worksheets("計算") Application.DisplayAlerts = False On Error Resume Next For k = 1 To Worksheets.Count - 8 If Worksheets(k).Name <> "計算" Then Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "BQ")).Copy ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select Selection.PasteSpecial Paste:=xlPasteValues End If Next k Application.CutCopyMode = False 空白列の削除 End Sub
- aitaine
- お礼率43% (170/393)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
★印の部分の処理を2回繰り返せばいいだけです。 Sub 計算表の一括複写() Application.ScreenUpdating = False Dim list, SheetName ActiveSheet.Unprotect Const EXCEPT_NAME = " 年月管理 最新明細 記録帳" Worksheets("計算").Activate Rows("2:33").Select Selection.Delete Shift:=xlUp Dim k As Long Dim ws As Worksheet Set ws = Worksheets("計算") Application.DisplayAlerts = False On Error Resume Next For k = 1 To Worksheets.Count - 8 If Worksheets(k).Name <> "計算" Then '★ Range(Worksheets(k).Cells(29, "B"), Worksheets(k).Cells(60, "I")).Copy ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select Selection.PasteSpecial Paste:=xlPasteValues ’★ Range(Worksheets(k).Cells(29, "BM"), Worksheets(k).Cells(60, "BM")).Copy ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).Select Selection.PasteSpecial Paste:=xlPasteValues End If Next k Application.CutCopyMode = False 空白列の削除 End Sub ★の書き方だと長すぎるので、 Worksheets(k).Range("B29:I60").Copy ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteValues Worksheets(k).Range("BM29:BM60").Copy ws.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteValues の方がわかりやすく、すっきりします。
関連するQ&A
- シート1の氏名をシート2に反映
sheet1の氏名をsheet2の日付、記号（A,B,C）にマッチした位置に入力させたいのですが下記コードで他で試したのですがうまくいきません。どなたかコードが解る方よろしくお願いします。 Sub 入力() Dim i As Long, j As Long, k As Long, L As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)) j = wS2.Cells(3, Columns.Count).End(xlToLeft).Column Range(wS2.Cells(3, 2), wS2.Cells(i, j)).ClearContents On Error Resume Next For i = 2 To wS1.Cells(Rows.Count, 4).End(xlUp).Row If WorksheetFunction.CountA(wS1.Rows(i)) > 1 Then For j = 2 To wS1.Cells(i, Columns.Count).End(xlToLeft).Column If wS1.Cells(i, j) <> "" Then k = WorksheetFunction.Match(wS1.Cells(i, 4), wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)), False) L = WorksheetFunction.Match(wS1.Cells(5, j), wS2.Rows(3), False) wS2.Cells(k, L) = wS1.Cells(i, j) End If Next j End If Next i End Sub
- ベストアンサー
- Visual Basic
- 決まったシートだけコピーして一つのシートにまとめる
お世話になります。 http://okwave.jp/qa/q8216220.html で質問させていただいたVBAをこねくり回してみたのですが、「インデックスが有効範囲にありません」というエラーがでて進まなくなってしまいました。 Sub 特定のシートだけコピーと貼り付け() Dim k As Long, endRow As Long, wS As Worksheet Dim P As Variant P = Array("全", , "A", "B", "C", "D", "E", "F", "G", "H", "I") '↑コピーしたいシート名一覧 Set wS = Worksheets("まとめ") endRow = wS.cells(Rows.Count, "B").End(xlUp).Row If endRow > 4 Then Range(wS.cells(5, "B"), wS.cells(endRow, "M")).ClearContents End If For k = LBound(P) To UBound(P) ☆If Worksheets(k).Name <> "まとめ" Then 'ワークシート名が"まとめ"のとき endRow = Worksheets(P).cells(Rows.Count, "B").End(xlUp).Row 'P＝Arrayで指定しているシートのセルで If endRow > 4 Then '4行目より下を Range(Worksheets(P).cells(5, "B"), Worksheets(P).cells(endRow, "M")).Copy _ wS.cells(Rows.Count, "B").End(xlUp).Offset(1) 'B5からM列の任意のデータが入っているセルまでコピーして"まとめ"シートに貼り付け End If '繰り返す End If '繰り返す Next k '次のシートへ End Sub 自分で分かるようにコメントを付けています。 ☆のついているところで、「インデックスが有効範囲にありません」と出ます。 指定したシートに"まとめ"を追加してみてもやはり同じでした。 調べたところ、「インデックスが～」というのはVBA中の範囲にないものを指定しているからだ、ということなのですが・・・。 お知恵を貸して下さい。よろしくお願いします。
- ベストアンサー
- その他MS Office製品
- 複数シートをループさせてマクロを簡素化したい
win7 Excel2007 でマクロ作成中の初心者です。 シート数の変動する複数シートの特定範囲を一枚のシートに右列方向に、値を貼り付けたいです。 自動記録でコード作成しましたが、もっと簡素化して軽くしたいです。 シートに対するループ等の作成ができません。どうかご指導お願いします。 Sub 勤怠最終データ作成() Worksheets(1).Select '1番左のシートを選択 ActiveSheet.Unprotect Range("B29:BM60").Select '複写範囲はすべて同じ Selection.Copy Sheets("総括").Select '値の貼り付けシートはすべて同じ Range("A2").Select '値の貼り付け先 Selection.PasteSpecial Paste:=xlPasteValues ’-------------------------------------- Worksheets(2).Select '2枚目のシートを複写 ActiveSheet.Unprotect Range("B29:BM60").Select Selection.Copy Sheets("総括").Select 最終セルの選択 '値の貼り付け先 Selection.PasteSpecial Paste:=xlPasteValues ’-------------------------------------- Worksheets(3).Select '3枚目のシートを複写 ActiveSheet.Unprotect Range("B29:BM60").Select Selection.Copy Sheets("総括").Select 最終セルの選択 Selection.PasteSpecial Paste:=xlPasteValues ’-------------------------------------- Worksheets(4).Select '4枚目のシートを複写 ActiveSheet.Unprotect Range("B29:BM60").Select Selection.Copy Sheets("総括").Select 最終セルの選択 Selection.PasteSpecial Paste:=xlPasteValues 以下省略 End Sub
- ベストアンサー
- Visual Basic
- VBA どこでもセル選択
教えて頂いたＶＢＡなのですがもう一つ Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j Counter = Counter + 1 If INP <> "" Then wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub -------------------------------------------------------------- For i = 3 のところを3としないでどのセル（行）にも対応させたいのですが どうすればいいでしょうか？
- ベストアンサー
- Excel（エクセル）
- ExcelVBAの転記（1つのひな形へ複数シート）
お世話になります。ExcelVBAを少し学んだ程度の者です。 1つのExcelファイルに複数存在する個別のシートから、1つのひな形シートへ転記する方法に頭を悩ませております。イメージとしては名簿管理のようなものとご理解してください。 複数存在するシート（約200シート）には、項目名に対するデータ（例えば、名前や住所などが定められたセルに入力されています）が揃っておりますが、書式の変更によりひな形のシートへ転記する必要があります。 200ほどのシートには、M10セルには名前が、B15セルには住所、C16セルには電話番号が……という具合に入力されています。これらのデータをひな形シートでは、N5セルに名前、C13セルに住所、D14セルには電話番号などを転記する必要があります（セル番地は適当です）。 ひな形シートは1枚で、マクロを実行する際にひな形シートをコピーして（Xとします）、200ほどの個別のシート（A、B、C……）を転記しようと思っております。A、B、C……に入力された複数の値は項目別にCells(i,j).Valueを、XへCells(x,y).Valueへ転記すれば良いと考えておりましたが、上手くいきません。ひな形をコピーしたXのシートへ上手く転記ができず、Aを転記したシートばかりが量産され、B、C以降のシートへ制御が移っていないようです。恐らく、Workwsheetオブジェクトのカウンタ変数に問題があると思われます。 VBAのコードとしては下記のように記述しております。 Sub SheetCopy() Application.ScreenUpdating = False Dim cnt As Long 'シート数カウント変数 Dim i As Long 'シート用のカウンタ変数 Dim wb As Workbook 'コピー元 Dim ws1 As Worksheet 'コピー元 Dim ws2 As Worksheet 'コピー先 '1がコピー元で2がコピー先 cnt = Worksheets.Count 'シート数をカウント i = 2 Set wb = Workbooks("転記用.xlsm") Set ws1 = wb.Worksheets(i) Set ws2 = wb.Worksheets("ひな形") For i = 1 To cnt ws2.Copy after:=Worksheets(i) Set ws2 = wb.Worksheets(i) ws2.Cells(2, 2).Value = ws1.Cells(2, 13).Value '名前 ws2.Cells(3, 2).Value = ws1.Cells(6, 10).Value '住所 以下、同様の転記処理を記述しています。 Next i End Sub 上記のコードを、パッと見たところ、コピーはしているものの、転記先がコピー元になっているのも原因だと思います（コピー先へ転記する方法が現時点でわかりかねます……ここがネックだと考えております）。 ご知見のある方々から、アドバイスをいただけると幸いです。 どうぞ、よろしくお願い申し上げます。
- ベストアンサー
- Excel（エクセル）
- 複数のシートを別ブックにコピーして保存したい
毎回、シート数が変動するEXCELファイルの、表示されているシートのみ（非表示シート有）を、 別のブックにコピーして、セルの書式と値を貼付けし、 元ファイルのシート名と同じシート名を付けたいのですが、 どんなVBAを組めば良いでしょうか？ 下記の様に作成してみましたが、ファイル自体がコピペされてしまう様で、 自分のイメージした通りに動きません・・・。 ご教授の程、宜しくお願いいたします。 Sub データ書き出し() Dim ws As Worksheet Dim i As Long With ActiveWorkbook i = Worksheets.Count For j = 1 To i ThisWorkbook.Worksheets(j).Cells.Copy .Worksheets(j).Range("A1").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Next j Application.CutCopyMode = False .SaveAs "月別DATA_" End With End Sub
- ベストアンサー
- その他MS Office製品
- 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
- ベストアンサー
- その他（プログラミング・開発）
- 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"), _ どなたかご教授の方お願い致します。
- ベストアンサー
- Visual Basic
- エクセルVBAの修正をお願いいたします。
下記VBAをご教授受けて何とか作りましたが、一行指定で作成したのですが、その時によりデータ数にばらつきがありますので、現状データがあるセルだけを拾ってきてデータのあるなしを、JのセルとKのセルに2種類表示するように作成したつもりですが、データがないセルにも延々と Jのセルには 1040272 Kのセルには * が表示されますのでデータが現状ないセルには何も表示されないようにしたいと思います。 自分でいろいろ調べながらしてみるのですが埒が明かない状態になっておりますので、なにとぞお助け、ご教授をお願いいたします。 わかりにくい説明で申し訳ございませんがなにとぞよろしくお願いいたします。 Range("H2").Select ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-5],RC[-4])" Selection.AutoFill Destination:=Range("H2:H10000") Range("H2:H10000").Select Columns("H:H").Select Selection.Copy Columns("I:I").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Replace what:="-", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.Replace what:="_", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Sheets("登録商品リスト").Select Columns("C:C").Select Application.CutCopyMode = False Selection.Copy Columns("E:E").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Replace what:="_", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.Replace what:="-", Replacement:="", lookat:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Range("F2").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=UPPER(RC[-1])" Selection.AutoFill Destination:=Range("F2:F10000") Range("F:F").Select Columns("F:F").Select Selection.Copy Columns("G:G").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("Sheet2").Select Range("J2").Select Application.CutCopyMode = False ActiveCell.FormulaR1C1 = "=COUNTIFS(登録商品リスト!C[-3],C[-1])" Selection.AutoFill Destination:=Range("J2:J1500") Range("J:J").Select Dim i As Long, endRow As Long, str As String, c As Range, wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("登録商品リスト") Set wS2 = Worksheets("Sheet2") endRow = wS2.Cells(Rows.Count, "K").End(xlUp).Row Application.ScreenUpdating = False If endRow > 1 Then Range(wS2.Cells(2, "K"), wS2.Cells(endRow, "K")).ClearContents End If For i = 2 To wS2.Cells(Rows.Count, "I").End(xlUp).Row str = Left(wS2.Cells(i, "I"), 5) Set c = wS1.Range("G:G").Find(what:=str, LookIn:=xlValues, lookat:=xlPart) If Not c Is Nothing Then wS2.Cells(i, "K") = "*" End If Next i Application.ScreenUpdating = True End Sub
- ベストアンサー
- Excel（エクセル）
- 複数ファイルの１つのシート中の総行数を求めるには
大変お世話になっております。 複数ファイルの１つのシート(カテーログ)中の最終行数を求めるのに、下記のマクロを書いて実行しましたが、エラーは出ませんが総行数など、何も反応がありません。なにも出力しない原因がお分かりでしたら、ご教示頂けると大変たすかります。まだまだマクロは超初心者です。 出力したい情報は、ファイル名とA列の3行目～最終行の総行数です。 Sub データ総行数求め() Dim fpath As String, fname As String Dim wb As Workbook, ws As Worksheet Dim crow As Long, cnt As Long fpath = "C:\Users\Owner\Documents\連結作業\202304-202309\)" fname = Dir(fpath & "*.xlsx") Set ws = ThisWorkbook.Worksheets("test") crow = 1 Do Until (fname = "") Set wb = Workbooks.Open(fpath & fname) If (sheet_chk(wb, "カテーログ") = True) Then cnt = count_row(wb.Worksheets("カテーログ")) Worksheets("カテーログ").Range("A3").Value ws.Cells(crow, 1).Value = fname ws.Cells(crow, 2).Value = "カテーログ" ws.Cells(crow, 3).Value = cnt crow = crow + 1 End If wb.Close fname = Dir() Loop End Sub '戻り値の定義 Function count_row(ByVal ws As Worksheet) As Long Dim k As Long, tmp As Long count_row = 0 For k = 1 To 256 tmp = ws.Cells(ws.Rows.Count, k).End(xlUp).Row If (tmp > count_row) Then count_row = tmp Next End Function Function sheet_chk(ByVal wb As Workbook, ByVal msg As String) As Boolean Dim w As Worksheet sheet_chk = False For Each w In wb.Worksheets If (w.Name = msg) Then sheet_chk = True Exit For End If Next End Function
- ベストアンサー
- Excel（エクセル）
お礼
ありがとうございました。早速やってみたら完璧に、しかも軽くなった分、肩もこらずにすいすいできました。本当に感謝もうしあげます。