質問: 追記:指定値以外の行データを抽出・転記する為には 画像と共に説明を追加致します。 e2、y4以下には変換した日付シリアル値が入力されています。 また年月は変化し、データの内容、行数も変化します。 添付画像は転記先別シートになります。 転記先シートは元データのシートと同じブック内に作成されています。 ◎y列のe2の年月以外の行の ・y列同行セルの年月データを別シートe7~14へ転記 ・e列同行セル(上4桁を指定数値に変更)をb7~14へ抽出 ・f列同行セル文字列をc7~14へ転記 ・s列同行セル数値をf7~14へ転記 ・t列同行セル数値をg7~14へ転記 ◎y列がe2の年月でc列が遅もしくは再という文字列の行の ・y列同行セルの年月データを別シートe16~23 ・e列同行セル(上4桁を指定数値に変更)をb16~23へ抽出 ・f列同行セル文字列をc16~23へ転記 ・s列同行セル数値をf16~23へ転記 ・t列同行セル数値をg16~23へ転記 その後、転記先シートの空欄行をフィルターで畳み印刷 私が試行したことは、e列数値から14000000を引き指定数値(360とした場合3600000)を加えれば目的の数値になるのではと関数式を作成したこと、 y列にフィルターを掛け、e2年月と等しくない日付を表示し、それをコピーして添付した場合、他の年月、データで行数が変わった場合、対応出来なくなるのではと、そこで詰まってしまったこと。 accessで行ったら出来るのではと調べ結果どっちつかずになってしまっていました。 説明もおぼつかない状況で煩雑な事を行おうとしており、最も相手にしたくない対象者であることは自覚しています。 にも関わらず、何度もお返事を下さり、本当に感謝致します。 不足してる情報や不明確な内容がありましたら、ご質問下さい。 宜しくお願い致します。
回答: no.2 の続きです。字数の関係で、コードはこちらに載せます。実行すると、添付図のような感じになります。 sub extractmonthlydata() dim lastrow as long, repnumber as long, cell as range, i as long, j as long, n as long repnumber = 360 '指定数値(整数) with worksheets("記録") lastrow = .cells(rows.count, "y").end(xlup).row .copy before:=worksheets(1) end with with worksheets(1) with .range("b2:y" & lastrow) on error resume next .value = .value on error goto 0 end with for each cell in .range("e4:e" & lastrow) cell.value = repnumber & right(cell.value, 4) next cell .range("b3:y" & lastrow).autofilter field:=24, criteria1:="<" & .range("e2").value j = 4 for i = 4 to lastrow if n = 8 then exit for if .rows(i).hidden = false then n = n + 1 j = i end if next i on error resume next .range("e4:f" & j).specialcells(xlcelltypevisible).copy destination:=worksheets("集計").range("b7") .range("s4:t" & j).specialcells(xlcelltypevisible).copy destination:=worksheets("集計").range("f7") .range("y4:y" & j).specialcells(xlcelltypevisible).copy destination:=worksheets("集計").range("e7") on error goto 0 j = 4 .range("b3:y" & lastrow).autofilter field:=24, criteria1:=format(.range("e2").value, "ggge""年""m""月""") .range("b3:y" & lastrow).autofilter field:=2, criteria1:="遅", operator:=xlor, criteria2:="再" for i = 4 to lastrow if n = 8 then exit for if .rows(i).hidden = false then n = n + 1 j = i end if next i on error resume next .range("e4:f" & j).specialcells(xlcelltypevisible).copy destination:=worksheets("集計").range("b16") .range("s4:t" & j).specialcells(xlcelltypevisible).copy destination:=worksheets("集計").range("f16") .range("y4:y" & j).specialcells(xlcelltypevisible).copy destination:=worksheets("集計").range("e16") on error goto 0 .range("e2").copy destination:=worksheets("集計").range("b26") end with worksheets("集計").range("b7:g23").borders.linestyle = xlcontinuous application.displayalerts = false worksheets(1).delete application.displayalerts = true worksheets("集計").select end sub