- 締切済み
【VBA】日付から遅延案件を抽出、新ファイルに転記
eden3616の回答
- eden3616
- ベストアンサー率65% (267/405)
5まではご自身でお望みの動作ができていると解釈したうえで 失礼ながら対象のデータ様式がご提示の文面からは掴みにくいため、 フィルタ後の転記のサンプルと冗長になっている箇所の改善を提示します。 ******************************************************************** (1) フィルタ後の転記 ******************************************************************** 新しく開いたブックにどのように転記するのかが不透明なため、 使用した範囲をそのままコピーしています。 次のサンプルでは新規ブックを開き、A1セルへ貼り付けています。 Sub sample() Dim myRng As Range 'A1セルから使用した最終セルまでの範囲を格納 Set myRng = Range(Range("A1"), Range("A1").SpecialCells(xlCellTypeLastCell)) '新規ブックを作成（特定のブックであれば開く処理を記述） Workbooks.Add '格納した範囲をコピーして貼り付け myRng.Copy Range("A1") End Sub ******************************************************************** (2) 冗長になっている箇所のまとめ ******************************************************************** 25セット記述されているフォント色の黒化と赤化及びコメント記載部は ご質問で提示された「BH、BI、BL、BO」列の配置パターンを読み解くと 以下のようにすることでまとめれるかと思います。 Cols = "BH,BI/BL,BO/〇〇,●●/△△,▲▲・・・" のように調査日と開始日の列記号を交互に二つずつ記載していただくことで 25セット分の列指定が一括でできるかと思います。 Dim Cols As String, myCols As Variant, myCol As Variant '調査日と開始日を交互に/で区切り記載。さらに各々出現する二つの日付列は,で区切る。 Cols = "BH,BI/BL,BO" For Each myCols In Split(Cols, "/") myCol = Split(myCols, ",") '調査日・開始日の予定日付を黒にする .Cells(i, myCol(0)).Font.Color = vbBlack '調査日・開始日の予定を赤字にしてコメント記載 If (.Cells(i, myCol(0)) <= DateC And .Cells(i, myCol(1)) >= MinDate) _ And (.Cells(i, myCol(0)) = "" Or .Cells(i, myCol(0)) <= MinDate) Then .Cells(i, myCol(1)).Font.Color = vbRed .Cells(i, LastROW + 1) = "遅延" End If Next myCols
関連するQ&A
- VBA転記について教えて下さい
200件位のデータがあるとします。顧客情報AB・商品C～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です。 １、項目名の転記でデータは200位ですが変動があるので最終行で作成したら うまくいきませんでした。 ２、データ域の転記が動きません。 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
- ベストアンサー
- Excel（エクセル）
- VBA マクロ シート 転記
はじめまして。VBA初心者です。今シート１のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート２のＢ列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート２の項目は同じ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 どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか？宜しくお願いします。
- ベストアンサー
- Visual Basic
- VBAでDateaddの日付計算で困っていることがあるので助けていただけないでしょうか。よろしくお願いします。
シート： A列には”注射”という文字を入れるようにします。 B列には1月1日から12月31日まで入っています。 C列はB列の90日後を入れるようにします。 D列はC列の3日前を入れます。・・・としたいのですがその3日の間A列に”注射”が入っていたらその日を入れずに3日前にしたいのです。 稼働日みたいな感じでしょうか・・・・ どうしたらよいでしょうか？お願いします。 例えば、B列の「1月1日」の90日後はC列「3月31日」でD列は通常「3月28日」が入っていますがB列「3月30日」の左のA列に”注射”があったらそこを無視して「3月27日」と入れたいのです。 Sub count() Dim i As Long Dim lastrow As Long lastrow = Range("B1").End(xlDown).Row For i = 1 To lastrow Cells(i, 3).Value = DateAdd("d", 90, Cells(i, 2).Value) Next For i = 1 To lastrow Cells(i, 4).Value = DateAdd("d", -3, Cells(i, 3).Value) Next End Sub 説明が下手なのでもしよかったら実際作ったものを見ていただいた方が分かるかもしれません。 http://briefcase.yahoo.co.jp/bc/robert_kubica_bmw/vwp2?.tok=bcf8oGbB4FXgt88k&.dir=/&.dnm=1count.xls&.src=bc
- ベストアンサー
- Visual Basic
- Excel VBAで文字列の部分一致の文字列を表示
以前、こちらで頭５文字までの一致で文字列を表示するVBAを教えて頂きました。今回はFINDなどの部分一致での文字列を表示することをしたいのですが、ご教示いただけますと幸いです。 下記はSheet1のA3に文字を5文字以内いれるとSheet２のC列からピックアップしてSheet１のA列に文字列を表示する及びSheet２のB列のデータをSheet１のC列に表示させるVBAです。 Sub Test2() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim SData As String, i As Long, VRet As Variant Dim c As Range, LastRow As Long Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") SData = CStr(Ws1.Range("A3").Value) If SData = "" Then Exit Sub i = 5 LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row If LastRow < i Then LastRow = i End If Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents With Ws2 For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp)) VRet = InStr(1, CStr(c.Value), SData, vbTextCompare) If VRet = 1 And Len(c.Value) >= 10 Then Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value 'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value i = i + 1 End If Next End With End Sub 宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
- vba ファイルの移動について
フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字３つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが（下に貼り付け）、 下から４行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で 「実行時エラー'53' ファイルが見つかりません。」 とエラーが出てしまいます。 どの様に書き直せばよいのでしょうか？ どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName 'ここでストップ End If Next End Sub
- ベストアンサー
- Excel（エクセル）
- VBAで転記すると#REF!に
いつもお世話になります。 WINDOWS7 EXCELL2010 です。 現在、請求書から売上表にマクロにて転記するファイルを作成中です。 添付図の上の画像でH列に数式を入れるまでは画像の下のようにマクロで入力するごとに5行が反転(範囲を選択したような)しながらもエラーなく入力できていました。 H列に数式を入れたときは画像の上でした。 ところがテストで請求書よりマクロにて入力すると画像の下のようにA10:G14で5行が反転してエラーが発生します。 マクロにて請求書から売上表に入力した時は必ずこの5行の反転が生じます。 私なりの見解ですがこの5行の反転がなにか悪戯しているのではないかと考えます。 下記にマクロとH列の数式を掲載します。 何か不都合または具合が悪いところがあるのでしょうか。 是非是非御指導いただけませんでしょうか。 Sub 売上表転記1() Dim i As Long, wS As Worksheet Set wS = Worksheets("売上表") Worksheets("納請書1").Range("L5:R9").Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues '★ Application.CutCopyMode = False For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1 '★ If WorksheetFunction.CountIf(wS.Cells(i, "A").Resize(, 4), "") = 4 Then wS.Cells(i, "A").Resize(, 4).Delete shift:=xlUp End If Next i End Sub 参考にH2 =IF(MONTH(A2)=MONTH(A3),"",SUMPRODUCT((MONTH(OFFSET($A$2,0,0,COUNT(A:A)))=MONTH(A2))*OFFSET($E$2,0,0,COUNT(A:A))))
- ベストアンサー
- Excel（エクセル）
- VBA 請求データ一覧からの複数の処理
先週 kkkkkmさんに質問をさせて頂きまして、 いろいろご指導を頂いたものです。 続編の様な形になってしまいますが、 抽出するデータの環境設定を変更致しました。 ご質問させて頂く内容は前回とほとんど変更がないのですが、 あらためて下記に記載させて頂きます。 <Worksheet1のデータ> Ｊ列～AM列までが課税金額 「J,K,L」「M,N,O」・・・「AK,AL,AM」と3列1組（コード・費目・金額） 1組の行もあれば、複数組の行もあり。 AN列～BB列までが非課税金額 課税金額と同じく3列1組 1組の行もあれば、複数組の行もあり。 「BC」=消費税、「ＢＤ」=合計金額 ※AN列の前に不規則な空白セルあり BC列の前に不規則な空白セルあり 文章で上手く説明出来ているか自信がありませんので、 エクスポートした元データ Worksheet1と、 vbaを用いて作成した Worksheet3 をご参考に添付致します。 Worksheet1の2行目がWorksheet3の2行目に対応しています。 3行目、4行目も同様です。 不規則な空白が原因でしょうか・・・。 M列、O列は問題ないのですが、 金額が合わなかったり、N列に金額を引いてこないのです。 実行しているコードは下記になります。 Dim i As Long, j As Long, k As Long Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet Dim mTotal(4) As Long Dim LastRow As Long Dim List(4) As Variant Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") Set Ws3 = Sheets("請求書ひな形") List(1) = Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)).Value List(2) = Ws2.Range(Ws2.Cells(1, "B"), Ws2.Cells(Rows.Count, "B").End(xlUp)).Value List(3) = Ws2.Range(Ws2.Cells(1, "C"), Ws2.Cells(Rows.Count, "C").End(xlUp)).Value List(4) = Ws2.Range(Ws2.Cells(1, "D"), Ws2.Cells(Rows.Count, "D").End(xlUp)).Value LastRow = UBound(List(1)) For i = 2 To 4 If LastRow < UBound(List(i)) Then LastRow = UBound(List(i)) End If Next For i = 2 To Ws1.Cells(Rows.Count, "J").End(xlUp).Row mTotal(1) = 0 mTotal(2) = 0 mTotal(3) = 0 mTotal(4) = 0 For j = Columns("J").Column To Columns("BB").Column Step 3 For k = 2 To LastRow If UBound(List(1)) >= k Then If Ws1.Cells(i, j).Value = List(1)(k, 1) Then mTotal(1) = mTotal(1) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(2)) >= k Then If Ws1.Cells(i, j).Value = List(2)(k, 1) Then mTotal(2) = mTotal(2) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(3)) >= k Then If Ws1.Cells(i, j).Value = List(3)(k, 1) Then mTotal(3) = mTotal(3) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(4)) >= k Then If Ws1.Cells(i, j).Value = List(4)(k, 1) Then mTotal(4) = mTotal(4) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If Next Next Ws3.Cells(i, "J").Value = mTotal(1) Ws3.Cells(i, "K").Value = mTotal(2) Ws3.Cells(i, "L").Value = mTotal(3) Ws3.Cells(i, "N").Value = mTotal(4) Ws3.Cells(i, "M").Value = Ws1.Cells(i, "BC").Value Ws3.Cells(i, "O").Value = Ws1.Cells(i, "BD").Value Next Set Ws1 = Nothing Set Ws2 = Nothing Set Ws3 = Nothing End Sub 本当に何度も申し訳ございません。 お時間がある時に見て頂けると有り難いです。 どうぞ宜しくお願い致します。
- ベストアンサー
- Excel（エクセル）
- 横にコピーするには・・。
教えてください・・。 01.xls・02.xls・03.xlsとあり、その中のシート（01・02・03）をコピーして、全部というシートにまとめたいと思っています。 列にデータを追加したいのですが、行にデータが追加されてしまいます・・。 どうしたらいいのか教えてください。 01のシートがＡからＤまで 02のシートがＥからＧまで 03のシートがＨからＬまで とコピーをしたいと思っています・・。 --------- PathName = ThisWorkbook.Path & "\" ArrBook = Array("01.xls", "02.xls", "03.xls") For i = LBound(ArrBook) To UBound(ArrBook) Workbooks.Open PathName & ArrBook(i) Next Set WS(1) = Workbooks("01.xls").Worksheets("01") Set WS(2) = Workbooks("02.xls").Worksheets("02") Set WS(3) = Workbooks("03.xls").Worksheets("03") Set WS(4) = ThisWorkbook.Worksheets("全部") With WS(4) .Cells.ClearContents .Cells(1, 1) = "Ａ" .Cells(1, 2) = "B" .Cells(1, 3) = "C" .Cells(1, 4) = "D" .Cells(1, 5) = "E" .Cells(1, 6) = "F" .Cells(1, 7) = "G" .Cells(1, 8) = "H" .Cells(1, 9) = "I" .Cells(1, 10) = "J" .Cells(1, 11) = "K" .Cells(1, 12) = "L" .Cells(1, 13) = "M" .Cells(1, 14) = "N" .Cells(1, 15) = "O" .Cells(1, 16) = "P" .Cells(1, 17) = "Q" LastRow(1) = WS(1).Range("A65536").End(xlUp).Row LastRow(2) = WS(2).Range("A65536").End(xlUp).Row LastRow(3) = WS(3).Range("A65536").End(xlUp).Row For i = 1 To 3 LastRow(4) = .Range("A65536").End(xlUp).Row + 1 WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1) LastRow(4) = .Range("A65536").End(xlUp).Row End With For i = LBound(ArrBook) To UBound(ArrBook) Workbooks(ArrBook(i)).Close SaveChanges:=False Next End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAで別のファイルの値を代入する記述
いつもお世話になってます。 エクセル2002で、2つのファイルを使ってVBAを組みたいと考えています。 下記のコードを『ファイルB』に記述しています。 A列のデータを、B列の回数分、C列に表示させています。 このC列に表示させている部分を『ファイルA』に直接書き出すには、 どのような記述が必要なのでしょうか？ 単純に『ファイルB』のC列を、『ファイルA』に、コピー＆ペーストする方法もあるかと思うのですが、 せっかくなので複数ファイルを対象に処理する記述にチャレンジしています。 が、なかなか思うような結果が得られません。 アドバイスをお願いいたします。 ---------------------- Sub tes1() Dim i As Integer Dim k As Integer Dim x As Integer Dim y As Integer With ActiveSheet.UsedRange lastrow = .Cells(.Count).Row End With x = 2 For i = 2 To lastrow k = Cells(i, 2) For k = 1 To k Cells(x, 3) = Cells(i, 1) x = x + 1 Next k Next i End Sub
- ベストアンサー
- オフィス系ソフト
- ＶＢＡで複数列からの条件指定でデータを抽出したい
講習会の受講者名簿を作成しています。（名簿は科目別で３つのシートに分かれています。） 現在下記モジュールで、受講者名・受講者番号を個々に入力し検索出来るようにしていますが、 受講日（例：2014/4/1～2014/4/31の間）で受講者を抽出できるようにしたいと考えています。 しかし、受講予定日は過去のものも含め複数列（I列～N列）まであり、受講者によって受講日の入力されている列がＩ列～Ｎ列間でまちまちです。 このような場合、どのようにＶＢＡを変更したら受講日で検索が可能になるでしょうか？ 宜しくお願いします。 Sub Sample2() Dim k As Long, endRow As Long, wS As Worksheet Set wS = Worksheets("検索＆抽出") If wS.Range("B1") = "" And wS.Range("B2") = "" Then MsgBox "検索データを入力してください" Exit Sub End If endRow = wS.Cells(Rows.Count, "A").End(xlUp).Row If endRow > 4 Then wS.Rows(5 & ":" & endRow).ClearContents End If For k = 2 To 4 With Worksheets(k) If wS.Range("B1") <> "" Then .Range("A1").AutoFilter field:=2, Criteria1:=wS.Range("B1") End If If wS.Range("B2") <> "" Then .Range("A2").AutoFilter field:=3, Criteria1:=wS.Range("B2") End If If .AutoFilter.FilterMode Then endRow = .Cells(Rows.Count, "A").End(xlUp).Row If endRow > 2 Then Range(.Cells(3, "A"), .Cells(endRow, "N")).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) End If .AutoFilterMode = False End If End With Next k End Sub
- ベストアンサー
- Excel（エクセル）
お礼
すいません、別ブックへの転記方法が詳しく書けていませんでした。フィルタをかけた状態で見えている箇所だけを転記したい、というのが今回の要望でした。 冗長になっている箇所の記述方法、大変勉強になりました。 自分でも見苦しい記述だなぁと思いながら書いていたのが、見違えるほどスッキリきれいな既述になりました。 こんなコードが書けるようになる日を夢見て、コツコツ勉強したいと思います。ありがとうございました。