エクセル マクロ 後列から条件を元に転記する

こんばんは　表題の通り、指定された条件に合致する範囲を抜き出し転記したいと思います。

画像のようなデータがあり、最後列から数えて2列目、3列目の範囲（この画像で言えばWW139～WX146）をB147～C154に数式ごと転記したいと思います。

またその時に、この画像ではWX列にエラーがありますが、WX列にエラーが無ければ、もしくはWX列に全て小数点を含む数字があれば、と言う条件で転記したいです。

なので、このパターンで言えばWXにエラーがあるので、それより前列を探しに行きます。

次の条件判定候補は11行前のWN列です。
WN列全てに小数点の文字が入って居れば、その列とひとつ前の列をB147～C154に数式ごと転記します。

その列がまたもやエラーの場合、また11列前のWDを判定すると言う形で、数字が見つかればその列と前の列を転記します。

詳しい方、よろしくお願い致します。

質問者からの補足コメント

• 

  ありがとうございます。
  
  平日ファイルが動いていて触れないので、見ながら考えて週末お返事したいと思います。
  
  助かります！

  No.4の回答に寄せられた補足コメントです。 補足日時：2022/02/07 11:06

• 

  ありがとうございます。
  
  平日ファイルが動いていて触れないので、見ながら考えて週末お返事したいと思います。
  
  助かります！

  No.3の回答に寄せられた補足コメントです。 補足日時：2022/02/07 11:07

No.4 ベストアンサー 回答者： Qchan1962 回答日時： 2022/02/06 23:32

こんばんは

＞ちょっと悪戦苦闘してみます。
ほぼコードを書いたつもりでしたが、

Sub try()
Dim r As Range, Rng As Range
Dim n As Integer
column_move:
If n > 10 Then Exit Sub
Set Rng = Range("X1:X5").Offset(, -n)
For Each r In Rng
If IsError(r) Then n = n + 10: GoTo column_move
If r = Int(r) Then n = n + 10: GoTo column_move
Next
Range("B147").Resize(Rng.Rows.Count, Rng.Columns.Count).Formula = Rng.Offset(, -1).Resize(, 2).Formula
Rng.Offset(, -1).Resize(, 2).Copy
Range("B147").PasteSpecial Paste:=xlPasteFormats ' 書式
Application.CutCopyMode = False
End Sub

プロシージャを書いておきます。ステップ実行などでテストして
条件分岐などを確認してみてください。

書式のコピーが不要な場合、
Rng.Offset(, -1).Resize(, 2).Copy
Range("B147").PasteSpecial Paste:=xlPasteFormats ' 書式
Application.CutCopyMode = False
は不要です

この回答へのお礼

週末、外部データの更新が止まってしまう事を忘れていて週初めから検証しました。

おかげさまで、目的の表示が出来るようになりました。

エクセル、関数、マクロは常時使う事ではなく、私のウィークポイントなのでちゃんと教えて頂き助かりました。

いつも、ありがとうございます。

お礼日時：2022/02/17 10:59

No.3 回答者： fujillin 回答日時： 2022/02/06 17:57

こんにちは

不明点がいろいろあるので、勝手に以下のように解釈しました。
＞最後列から数えて2列目、3列目の範囲
・最終列の判断方法が不明なので、ひとまずWW:WX列からスタートするものとします。

＞次の条件判定候補は11行前のWN列です。
・11行　→　10列　と解釈

・エラーの有無、小数点の有無に関しては「一つでも該当セルがあれば」NGと解釈
WX列の場合で言えば、以下の数式で判断します。
=ISERROR(SUM(WX139:WX146)+SUMPRODUCT(FIND(".",WX139:WX146)*1))
数式の結果が False の場合に、その列を採用します。
小数点の判断は、表示値ではなく実質の値になりますので、整数（例えば「1」など）はNGとなります。（表示書式で「1.0」などとなっていてもNGになります）

・B列迄戻っても該当範囲がない場合は、B147:C154は空白のまま終了します。

＞数式ごと転記したいと思います。
・値の転記ではないということなので、手操作でのセルのコピペと同じ状態で転記します。
（結果的に、数式内のセル参照などはエクセルにより自動変換されます）

※ 上記の解釈が異なっている場合は、適宜修正願います。

以下、ご参考までに。

Sub Q12791846()
Dim Rng As Range, tRng As Range
Dim B As Boolean, calc

Const f = "=ISERROR(SUM(@)+SUMPRODUCT(FIND(""."",@)*1))"
Set tRng = Range("WX139:WX146")
Set Rng = Range("B147:C154")

calc = Application.Calculation
Application.Calculation = xlCalculationManual
Rng.ClearContents

Do
Rng(1).FormulaLocal = Replace(f, "@", tRng.Address)
B = Rng(1).Value
Rng(1).ClearContents
If Not B Then
tRng.Offset(, -1).Resize(, 2).Copy Rng
Exit Do
End If
If tRng(1).Column > 11 Then Set tRng = tRng.Offset(, -10) Else Exit Do
Loop

Application.Calculation = calc
End Sub

No.2 回答者： Qchan1962 回答日時： 2022/02/05 22:26

こんばんは

＞WX列にエラーが無ければ、もしくはWX列に全て小数点を含む数字があれば、と言う条件
＞次の条件判定候補は11行前のWN列

エラーがあれば、整数があれば実行しないと言う事で
column_move:
If n > 10 Then Exit Sub
Set Rng = Range("WX139:WX146").Offset(, -n)
For Each r In Rng
If IsError(r) Then n = n + 10: GoTo column_move
If r = Int(r) Then n = n + 10: GoTo column_move
Next

＞WW139～WX146）をB147～C154に数式ごと転記
＞数式ごと
数式の参照先はそのままと言う事でしょうか

Range("B147").Resize(Rng.Rows.Count, Rng.Columns.Count).Formula = Rng.Offset(, -1).Resize(, 2).Formula

書式部分
Rng.Offset(, -1).Resize(, 2).Copy
Range("B147").PasteSpecial Paste:=xlPasteFormats ' 書式
Application.CutCopyMode = False

GoToを使っているので分かり難いかも知れませんが、
条件をなぞる形で書いてみました
次の条件が更にある場合、If n > 10 Then Exit Subで調整してください

この回答へのお礼

すみません、せっかく教えて頂きましたが、当方の知識が全く足りないようで、ちんぷんかんぷんです。

ちょっと悪戦苦闘してみます。

ありがとうございます。

お礼日時：2022/02/05 22:48

No.1 回答者： sNowRatio 回答日時： 2022/02/05 20:09

IsErrorとかで反応しなかったでしたっけ？（うろ覚え）

この回答へのお礼

えーっと
マクロ初心者で変数とかループとか全然解らないので、これを聞いても使えそうにありません

ありがとうござました。

お礼日時：2022/02/05 22:49