エクセルの学校：全文検索：Hyper Estraier：（Mook）

Results of 1 - 1 of about 1215 for （Mook） (0.001 sec.)

[[20150331213635]]: #score: 9211; @digest: c09db112700213b025878d77380e61cb; @id: 67655; @mdate: 2015-04-02T13:10:45Z; @size: 22211; @type: text/plain; #keywords: setcoltop (150358), fromsh (127614), frombk (87217), fromnm (81198), fdate (73949), setpos (71126), selnms (67484), 目c3 (54155), 目a3 (48506), 目b3 (47063), 目b2 (40389), 目c2 (38956), tdate (34784), 目a2 (29340), dstws (25651), tosh (21289), ウコ (17883), done (16224), 象ブ (15058), 出対 (14274), 項目 (9271), 覧シ (9156), fname (8881), fpath (8408), 刷用 (5489), autofilter (5308), 対象 (3957), ブッ (3636), 始日 (3633), thisworkbook (3412), 日付 (3213), 2015 (2918); 『表から1周間分の名前を抜き出すマクロ』（ユウコ）
お世話になります。シート名は月（m月）、中に日付入りの表が縦に並んでおり B列に日付があり、表は日付を入れて30行ですその表が1年分あったとして（日付はランダムです）同じ形式のブックが複数あります（仮にAA,BB,CC,DD,EEとして）印刷用ブック「一覧」シートからマクロを動かしたら明日から7日間の日付を検索し、該当表のA:C行を一覧シートのA1からC30までコピーし、次の表は D1からF30へ…というように横にコピーたいのです。意味は理解してもらえるでしょうか? 贅沢な注文で申し訳ありませんが、このようなことは可能でしょうか? 皆様、お力添えをよろしくお願いします。＜使用 Excel:Excel2010、使用 OS:Windows7 ＞ ---- いくつか確認したいのですが、・どのファイルのどのシートからコピーしたという情報はなくともよいのですか。・7日間の日付を検索とは、例えば3/28 日に実行したら、3月と4月のシートが対象になるのですか。・日付には年の情報があるのでしょうか（12月に実行したら、1月は今年?来年?）。 （Mook） 2015/03/31(火) 22:21 ---- MooKさまありがとうございます。確かにそうでした… ・可能であれば1行目（空行）にブック名が入るとありがたいです・月末の検索の場合はシートがまたぐことになります・日付は書式をmm/dd/(aaa)で表示していありますお手数をお掛けします。よろしくお願いします。（ユウコ） 2015/04/01(水) 06:45 ---- とりあえずのサンプルです。 1行目にファイル名、2行目にシート名、4行目以降にデータをコピーしています。検索対象は、マクロのあるブックと同じフォルダにあるファイルです。 Sub Sample() '// ツール ⇒ 参照設定 Microsoft Scripting Runtime にチェック Dim fso As New Scripting.FileSystemObject Dim dstWS As Worksheet Set dstWS = ThisWorkbook.Worksheets("一覧") dstWS.Cells.Clear Dim f For Each f In fso.GetFolder(ThisWorkbook.Path).Files If f.Name <> ThisWorkbook.Name Then If InStr(UCase(fso.GetExtensionName(f.Name)), "XLS") > 0 Then dataCopy f.Path, dstWS, Date + 1, Date + 7 End If End If Next End Sub Sub dataCopy(dataPath As String, dstWS As Worksheet, sd As Date, ed As Date) Dim ws As Worksheet Dim t Dim r As Long Dim c As Long With Workbooks.Open(dataPath) For Each ws In .Worksheets t = ws.Range("A1:C30") For r = 1 To 30 If t(r, 2) <> "" Then If t(r, 2) >= sd And t(r, 2) <= ed Then c = dstWS.Cells(1, Columns.Count).End(xlToLeft).Column If dstWS.Cells(1, c).Value <> "" Then c = c + 3 dstWS.Cells(1, c).Value = .Name dstWS.Cells(2, c).Value = ws.Name ws.Range("A1:C30").Copy dstWS.Cells(4, c).Resize(30, 3) dstWS.Cells(4, c).Resize(30, 3).Value = dstWS.Cells(4, c).Resize(30, 3).Value Exit For End If End If Next Next .Close False End With End Sub （Mook） 2015/04/01(水) 10:48 ---- AA,BBといったブックのシートの1行目がタイトル行であれば、フィルタリング機能が使えます。効率的にはフィルターオプション（フィルター詳細設定）が優れていますが、各ブックのタイトル文字列の不一致によっては障害になるケースがありますので、オートフィルター機能を使いました。月またがりの場合は同じ列の下に転記します。ブックが保存されているフォルダ、以下の例では DeskTop上の "test" という名前にしてあります。追記です。（11:36) 当日日付を基本に処理すると、後日に処理したい場合に、困ってしまうことが往々にしてあります。なので、以下の例では、デフォルトとして、翌日の日付を表示して、それでよければOKをクリック、後追い処理等の場合は、抽出開始日を打ち直してOKをクリック。日付は 2015/3/26 といった形でもいいですし、2015年3月26日といった形でもいいです。またまた追記です。 (11:47) マクロブックが同じフォルダにあった場合のスキップを追加しました。 Sub Test() Dim fDate As Date Dim tDate As Date Dim fPath As String Dim fName As String Dim fromNM As String Dim toNM As String Dim fromSh As Worksheet Dim toSh As Worksheet Dim fromBk As Workbook Dim selNMs As Variant Dim shn As Variant Dim setColTop As Range Dim setpos As Range Dim done As Boolean Application.ScreenUpdating = False '初期値を翌日として開始日付を指定 fDate = Date + 1 fDate = Application.InputBox("抽出開始日を指定してください", "日付指定", Default:=Format(fDate, "yyyy年m月d日"), Type:=1) If fDate = 0 Then Exit Sub 'キャンセルボタン tDate = fDate + 6 '終了日付 fromNM = Month(fDate) & "月" '抽出対象開始シート名 toNM = Month(tDate) & "月" '抽出対象終了シート名 If fromNM = toNM Then selNMs = Array(fromNM) Else selNMs = Array(fromNM, toNM) End If Set toSh = ThisWorkbook.Sheets("一覧") toSh.UsedRange.ClearContents '処理前に一覧シートをクリア Set setColTop = toSh.Range("A1") '転記開始セル '★抽出対象ブックのフォルダパス。実際のものに変更 fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "¥TEST¥" fName = Dir(fPath & "*.xls") 'フォルダからブックを抽出 Do While fName <> "" If fName <> ThisWorkbook.Name Then Set fromBk = Workbooks.Open(fPath & fName) '対象ブックを開く done = False For Each shn In selNMs Set fromSh = Nothing On Error Resume Next Set fromSh = fromBk.Sheets(shn) '対象シート On Error GoTo 0 If fromSh Is Nothing Then MsgBox fromBk.Name & " に " & shn & "がないのでスキップします" Else fromSh.AutoFilterMode = False 'オートフィルター解除 fromSh.Range("A1").AutoFilter 2, ">=" & CDbl(fDate), xlAnd, "<=" & CDbl(tDate) '抽出があれば If Not done Then setColTop.Value = fName If fromSh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then Set setpos = setColTop.Offset(1) If done Then Set setpos = setColTop.End(xlDown).Offset(1) '転記 If done Then Intersect(fromSh.AutoFilter.Range, fromSh.AutoFilter.Range.Offset(1)).Copy setpos Else fromSh.AutoFilter.Range.Copy setpos End If done = True End If End If Next fromBk.Close False '対象ブックを閉じる fName = Dir() '次のブック Set setColTop = setColTop.Offset(, 3) '次の転記位置 End If Loop End Sub （β） 2015/04/01(水) 11:35 ---- Mookさん、βさんありがとうございます。いま、試行できる環境にないので試行して、またお助け頂くと思います。少々お待ちください。（ユウコ） 2015/04/01(水) 16:01 ---- Mookさん遅くなりました。 With Workbooks.Open(dataPath)のところでエラーがでます。「エクセルで$印刷用.xlsmを開くことができません…」という内容です印刷用ブックは対象ブックと同じフォルダに入っておりそれを開いてマクロを動かしております。わたしが大きな勘違いをしているのでしょうか。申し訳ありません。尚、フォルダには検索対象以外のブックもいくつか含まれています。お手数をお掛けします。 βさん、1行目は空白、2行目に日付のみ、3行目が見出、4行目以降がデータですその表が30行ごとに縦にずらっと並んでいます、時間がなくて、これから教えて頂いたものを施行してみます遅くなってすいません。（ユウコ） 2015/04/01(水) 21:19 ---- >βさん、1行目は空白、2行目に日付のみ、3行目が見出、4行目以降がデータです >その表が30行ごとに縦にずらっと並んでいます、であれば、コードが意識しているレイアウトとは異なりますので、実行しても無意味ですよ。（β） 2015/04/01(水) 21:28 ---- 通常のファイルに $ が付くことがなければ、 If f.Name <> ThisWorkbook.Name Then を If f.Name <> ThisWorkbook.Name And InStr( f.Name, "$" ) = 0 Then としてみてください。データは、縦に複数セットありますか。 30行だけだと思い込んでいましたが。 （Mook） 2015/04/01(水) 21:50 ---- レイアウトをそちらのものに合わせ、マクロブックフォルダと対象ブックフォルダを同じ場所にしたコードです。 Sub Test2() Dim fDate As Date Dim tDate As Date Dim fPath As String Dim fName As String Dim fromNM As String Dim toNM As String Dim fromSh As Worksheet Dim toSh As Worksheet Dim fromBk As Workbook Dim selNMs As Variant Dim shn As Variant Dim setColTop As Range Dim setpos As Range Dim done As Boolean Dim afR As Range Application.ScreenUpdating = False '初期値を翌日として開始日付を指定 fDate = Date + 1 fDate = Application.InputBox("抽出開始日を指定してください", "日付指定", Default:=Format(fDate, "yyyy年m月d日"), Type:=1) If fDate = 0 Then Exit Sub 'キャンセルボタン tDate = fDate + 6 '終了日付 fromNM = Month(fDate) & "月" '抽出対象開始シート名 toNM = Month(tDate) & "月" '抽出対象終了シート名 If fromNM = toNM Then selNMs = Array(fromNM) Else selNMs = Array(fromNM, toNM) End If Set toSh = ThisWorkbook.Sheets("一覧") toSh.UsedRange.ClearContents '処理前に一覧シートをクリア Set setColTop = toSh.Range("A1") '転記開始セル fPath = ThisWorkbook.Path & "¥" fName = Dir(fPath & "*.xls") 'フォルダからブックを抽出 Do While fName <> "" If fName <> ThisWorkbook.Name Then Set fromBk = Workbooks.Open(fPath & fName) '対象ブックを開く done = False For Each shn In selNMs Set fromSh = Nothing On Error Resume Next Set fromSh = fromBk.Sheets(shn) '対象シート On Error GoTo 0 If fromSh Is Nothing Then MsgBox fromBk.Name & " に " & shn & "がないのでスキップします" Else fromSh.AutoFilterMode = False 'オートフィルター解除 Set afR = fromSh.Range("A3", fromSh.Range("A" & Rows.Count).End(xlUp)).Resize(, 3) afR.AutoFilter 2, ">=" & CDbl(fDate), xlAnd, "<=" & CDbl(tDate) '抽出があれば If Not done Then setColTop.Value = fName If fromSh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then Set setpos = setColTop.Offset(1) If done Then Set setpos = setColTop.End(xlDown).Offset(1) '転記 If done Then Intersect(fromSh.AutoFilter.Range, fromSh.AutoFilter.Range.Offset(1)).Copy setpos Else fromSh.AutoFilter.Range.Copy setpos End If done = True End If End If Next fromBk.Close False '対象ブックを閉じる Set setColTop = setColTop.Offset(, 3) '次の転記位置 End If fName = Dir() '次のブック Loop End Sub （β） 2015/04/01(水) 22:09 ---- Mookさん、βさんありがとうございます私の説明が大変・大変下手くそでご迷惑をお掛けしているようで大変心苦しいです。更に説明不足の部分も発覚し、もう一度説明させてもらいます（お二人にマクロはしっかり動きました）一番説明不足だったのは検索対象ブックに年度のカレンダーが1シート含まれていた点です。日付だけで検索して頂いていたため、それが検索であたってしまって印刷用に抽出されています検索対象から各ブックの左端にある「カレンダー」シートを省くことは可能でしょうか? もし無理でしたら、手作業で削除できます。あともう一つ…（本当にすいません）私の表の提示が間違っていました。 1行目空白行と書きましたが、各シート（m月）の最初の1行目だけが空白行で、 2行目からは、空白行がありませんでした。しかも毎回空白行があると思っていたので、表の行数も間違っていました。各シートの1番最初の行だけ空白で、2行目から表が始まります表の最初のB列に日付（mm月dd日(aaa)があり、1つの表は日付を入れて29行です。指定日（明日から7日）以内の日付があった場合 1行目にブック名を入れその下に日付のある表のA1行目からC29行目までのデータを印刷用ブック「一覧」シートに貼り、それ以降の対象日データは印刷用ブックに横に張付けていきたいのです。全く周りっくどい表現しかできず、ほんとうにごめんなさい。 Mookさんのマクロは、多分私の行の説明間違いで対象日の検索がずれてしまっていたようです。 βさんのは、「日付があれば表を含むA〜C29行を」の部分が上手く伝わっていなかったようで、対象の日付だけが抽出さました。お二人、本当にお手数をお掛けします。よろしくお願いします。（ユウコ） 2015/04/02(木) 06:08 ---- この手のものは、いくら言葉で説明しても、やはり受け取り側に誤解が生じる可能性があります。レイアウトサンプルを目で見てわかる形で、アップされてはいかがでしょう。「学校」内に、たくさん事例がありますが、 [[20150330153541]] 『受注データから在庫一覧をもとに、上から順に在庫』（NAO）とか、 [[20150206135317]] 『リストの不連続印刷について』（sarara）にあるような形で。（β） 2015/04/02(木) 06:17 ---- まず、m月シートのレイアウト、1行目から30行目までは以下でいいですか? それとも、どこか違っていますか? 次に、31行目から59行目までは、こんな感じでいいですか?それとも違っていますか? それと、以下の日付が範囲内だった場合、この m月シートの、どこからどこまでを、一覧シートの、どこに、どのように転記をしますか? [A] [B] [C] [1] 空白行 [2] ああああ 2015/4/1 いいいい [3] 項目A1 項目B1 項目C1 [4] 項目A2 項目B2 項目C2 [5] 項目A3 項目B3 項目C3 [6] 項目A4 項目B4 項目C4 [7] 項目A5 項目B5 項目C5 途中省略 [28] 項目A26 項目B26 項目C26 [29] 項目A27 項目B27 項目C27 [30] 項目A28 項目B28 項目C28 [31] うううう 2015/4/2 ええええ [32] 項目A30 項目B30 項目C30 [33] 項目A31 項目B31 項目C31 [34] 項目A32 項目B32 項目C32 [35] 項目A33 項目B33 項目C33 [36] 項目A34 項目B34 項目C34 [37] 項目A35 項目B35 項目C35 途中省略 [58] 項目A56 項目B56 項目C56 [59] 項目A57 項目B57 項目C57 （β） 2015/04/02(木) 08:58 ---- βさんの想定データで変更しました。 Sub Sample() '// ツール ⇒ 参照設定 Microsoft Scripting Runtime にチェック Dim fso As New Scripting.FileSystemObject Dim dstWS As Worksheet Set dstWS = ThisWorkbook.Worksheets("一覧") dstWS.Cells.Clear Dim f For Each f In fso.GetFolder(ThisWorkbook.Path).Files If f.Name <> ThisWorkbook.Name And InStr(f.Name, "$") = 0 Then If InStr(UCase(fso.GetExtensionName(f.Name)), "XLS") > 0 Then dataCopy f.Path, dstWS, Date + 1, Date + 7 End If End If Next End Sub Sub dataCopy(dataPath As String, dstWS As Worksheet, sd As Date, ed As Date) Dim t Dim r As Long Dim c As Long Dim ws As Worksheet Dim wa If Month(sd) = Month(ed) Then wa = Array(Month(sd) & "月") Else wa = Array(Month(sd) & "月", Month(ed) & "月") End If Dim wi As Long With Workbooks.Open(dataPath) For wi = 0 To UBound(wa) On Error Resume Next Set ws = .Worksheets(wa(wi)) On Error GoTo 0 If Not ws Is Nothing Then For r = 1 To ws.Cells(Rows.Count, "B").End(xlUp).Row If IsDate(ws.Cells(r, "B").Value) = True Then If ws.Cells(r, "B").Value >= sd And ws.Cells(r, "B").Value <= ed Then c = dstWS.Cells(1, Columns.Count).End(xlToLeft).Column If dstWS.Cells(1, c).Value <> "" Then c = c + 3 dstWS.Cells(1, c).Value = .Name dstWS.Cells(2, c).Value = ws.Name ws.Cells(r, "A").Resize(29, 3).Copy dstWS.Cells(4, c).Resize(29, 3) dstWS.Cells(4, c).Resize(29, 3).Value = dstWS.Cells(4, c).Resize(29, 3).Value End If End If Next End If Next .Close False End With End Sub （Mook） 2015/04/02(木) 14:10 ---- 本題とずれますが、横からお邪魔します。投稿用にレイアウトしてくれる便利なコードを以前momoさんが作成してくれていますのでご紹介〜 [[20110209184943]] 『[談]シートレイアウトの投稿どうしてますか?』（momo）（とおりすがりん♪） 2015/04/02(木) 18:16 ---- わぁ! これは便利ですねぇ。早速使わせてもらいます。以下は、どうなるんだろうということで、ちょこちょこっとシート上で作成したものです。 |[A] |[B] |[C] |[D] [1]|項目1 |項目2|項目3 |項目4 [2]|あああ1| 100| 10| 20 [3]|あああ2| 200| 30| 40 [4]|あああ3| 300|=SUM(C2:C3)|=SUM(D2:D3) [5]|あああ4| 400| 100| 200 [6]|あああ5| 500| 300| 400 [7]|あああ6| 600|=SUM(C5:C6)|=SUM(D5:D6) （β） 2015/04/02(木) 19:14 ---- みなさん色々ありがとうございます。お返事が遅くなりすいません。年度はじめで非常に非常に忙しくて… 表を実際書けばよかったのですね。頭が回らずすいません。先に結論をお話してしまいますが、Mookさんのマクロで希望通りに動いたようです（まだ詳細が確認できていないですが）表ですがAA〜EEのブックは最初がカレンダーシートでそれ以降 mm月シートで以下の配列です [A] [B] [C]・・・ [1] 空白行 [2] 日付 [3] 項目A1 項目B1 項目C1 [4] 項目A2 項目B2 項目C2 [5] 項目A3 項目B3 項目C3 途中省略 [29] 項目A27 項目B27 項目C27 [30] 項目A28 項目B28 項目C28 [31] 項目A29 項目B29 項目C29 [32] 日付 [33] 項目A31 項目B31 項目C31 [34] 項目A32 項目B32 項目C32 以下500行程度まで印刷用ブックの一覧シートは白紙でそこのマクロを発動させたら、各ブックから7日以内の日付を検索し日付があれば日付と以下のA〜C列の日付を含めて29行をコピーし一覧シートのA列〜C列、D列〜F列へと横に貼り付けていきたいというものでした。詳細を確認し、またお返事いたします。（ユウコ） 2015/04/02(木) 21:51 ---- それでは、私がアップしたオートフィルター版を無理やり（?）継承したものを。ただし、Mookさんの結果は、月ごとに転記列をわけておられますが、私のコードは、1つのブックからは月またがりの場合も同じ列に転記します。 Sub Test3() Dim fDate As Date Dim tDate As Date Dim fPath As String Dim fName As String Dim fromNM As String Dim toNM As String Dim fromSh As Worksheet Dim toSh As Worksheet Dim fromBk As Workbook Dim selNMs As Variant Dim shn As Variant Dim setColTop As Range Dim setpos As Range Dim done As Boolean Dim afR As Range Application.ScreenUpdating = False '初期値を翌日として開始日付を指定 fDate = Date + 1 fDate = Application.InputBox("抽出開始日を指定してください", "日付指定", Default:=Format(fDate, "yyyy年m月d日"), Type:=1) If fDate = 0 Then Exit Sub 'キャンセルボタン tDate = fDate + 6 '終了日付 fromNM = Month(fDate) & "月" '抽出対象開始シート名 toNM = Month(tDate) & "月" '抽出対象終了シート名 If fromNM = toNM Then selNMs = Array(fromNM) Else selNMs = Array(fromNM, toNM) End If Set toSh = ThisWorkbook.Sheets("一覧") toSh.UsedRange.ClearContents '処理前に一覧シートをクリア Set setColTop = toSh.Range("A1") '転記開始セル fPath = ThisWorkbook.Path & "¥" fName = Dir(fPath & "*.xls") 'フォルダからブックを抽出 Do While fName <> "" If fName <> ThisWorkbook.Name Then Set fromBk = Workbooks.Open(fPath & fName) '対象ブックを開く done = False For Each shn In selNMs Set fromSh = Nothing On Error Resume Next Set fromSh = fromBk.Sheets(shn) '対象シート On Error GoTo 0 If fromSh Is Nothing Then MsgBox fromBk.Name & " に " & shn & "がないのでスキップします" Else fromSh.AutoFilterMode = False 'オートフィルター解除 fromSh.Range("A1:D1").Value = "A" 'Dummy Title Set afR = fromSh.Range("A1").CurrentRegion.Columns("A:D") afR.Offset(1, 3).Resize(afR.Rows.Count - 1, 1).Formula = "=OFFSET(B2,-MOD((ROW()-2+29),29),0)" afR.AutoFilter 4, ">=" & CDbl(fDate), xlAnd, "<=" & CDbl(tDate) '抽出があれば If Not done Then setColTop.Value = fName If fromSh.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then Set setpos = setColTop.Offset(1) If done Then Set setpos = setColTop.End(xlDown).Offset(1) '転記 Intersect(fromSh.AutoFilter.Range, fromSh.AutoFilter.Range.Offset(1)).Columns("A:C").Copy setpos done = True End If End If Next fromBk.Close False '対象ブックを閉じる Set setColTop = setColTop.Offset(, 3) '次の転記位置 End If fName = Dir() '次のブック Loop End Sub （β） 2015/04/02(木) 22:10 ...; http://www.excel.studio-kazu.jp/wiki/kazuwiki/201503/20150331213635.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ