Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2013)
指定した列(B列)に特定の文字が入力されていた場合、その行(X行)のG列の文字を別シートのB13〜B100に転記したい
投稿日時: 20/06/29 17:35:28
投稿者: ザックん

いつも大変お世話になっております。
 
早速ですが、下記の様な事をしたいと考えております。
指定した列(B列)に特定の数値が入力されていた場合、その行(〇〇行)のA列とG列の文字/数値を
別シートのA列は(13,2)〜(100,2)に、G列は(13,4)〜(100,4)に転記したい。
 
宜しくお願い致し致します。
 
 

回答
投稿日時: 20/06/29 17:58:27
投稿者: WinArrow
投稿者のウェブサイトに移動

コードの作成依頼ですか?
 
手操作をマクロの記録でオードが作成できますから、
実施してみましょう。
 
セルやシートが固定的なので、マクロの記録で作成したコードが
そのまま使えう部分が多いと思います。
頑張って挑戦してみましょう。

投稿日時: 20/06/30 08:10:46
投稿者: ザックん

早速のご返答ありがとうございます。
 
そうなんですね。内容が複雑なものと思いこんでいました。
挑戦してみたいと思います。

投稿日時: 20/06/30 09:21:59
投稿者: ザックん

  お世話になっております。
 作成してみましたが、
    .Range("I7:I100").Selectのところでエラーメッセージが出てしまいます。
 
シートを指定していないから?でしょうか。
宜しくお願い致し致します。
 
    Sub 特定の文字を転記()
    Dim rng, rngEnd As Range
    With ThisWorkbook.Worksheets("Sheet")
    Set rng = .Range("T:T").Find("280")
    If (rng Is Nothing) Then
            MsgBox ("280はありません")
    Else
    Set rngEnd = rng
    Do
    .Range("I7:I100").Select
    Selection.Copy
    Sheets("出荷速報").Select
    Range("B13:B100").Select
     
    Range("J7:J100").Select
    Selection.Copy
    Sheets("出荷速報").Select
    Range("D13:D100").Select
    ActiveSheet.Paste
              
    Set rng = .Range("T:T").FindNext(rng)
    Loop While rng.Row <> rngEnd.Row
    End If
    End With
End Sub

投稿日時: 20/06/30 12:51:55
投稿者: ザックん

  お世話になっております。
修正してみたところ、出荷速報シートには転記されるようになりました。
しかし、まだ特定数値”280”のある行のところだけ転記したいのですが、
うまくできません。教えて頂きたく宜しくお願い致し致します。
 
 
    Sub 特定の文字検索()
 
    Dim rng, rngEnd As RANGE
    With ThisWorkbook.Worksheets("Sheet")
        Set rng = .RANGE("T:T").Find("280")
        If (rng Is Nothing) Then
            MsgBox ("280はありません")
        Else
  
            Set rngEnd = rng
     
    Do
 
                Set rng = .RANGE("T:T").FindNext(rng)
            Loop While rng.Row <> rngEnd.Row
        End If
    End With
     
         With ThisWorkbook.Worksheets("SHEET")
   
    RANGE("I7:I18").Select
    Selection.Copy
    Sheets("出荷速報").Select
    RANGE("B13:B18").Select
    ActiveSheet.Paste
    End With
     
    Sheets("sheet").Select
     
     
    With ThisWorkbook.Worksheets("SHEET")
     
    RANGE("J7:J18").Select
    Selection.Copy
    Sheets("出荷速報").Select
    RANGE("D13:D18").Select
    ActiveSheet.Paste
 
 
     End With
      
     
     
    End Sub

回答
投稿日時: 20/06/30 12:56:20
投稿者: WinArrow
投稿者のウェブサイトに移動

何をしようとしているか?
日本語の箇条書きで説明できますか?

投稿日時: 20/06/30 12:59:34
投稿者: ザックん

お世話になっております。
すみません。
初心者なもので現状、説明することができません。

回答
投稿日時: 20/06/30 15:43:03
投稿者: WinArrow
投稿者のウェブサイトに移動

コード作成を先走らないで、
 
まず、
やりたいことを整理しましょう。
 
かなり抽象的だが、
○○シートの中に、セル範囲(◆◆)が合います。
この中で、△△を条件として、条件に合致するものを
□□シートのセル範囲(■■)に複写したいです。
 
というような形式で
具体的に箇条書きしましょう。
 
 
 
 

投稿日時: 20/06/30 16:37:25
投稿者: ザックん

アドバイスありがとうございます。
 
整理してみますね。

投稿日時: 20/06/30 18:53:28
投稿者: ザックん

WinArrowさん
お世話になっております。
箇条書きにしてみました。
 
 If RANGE("T:T").Value = "280" Then でエラーメッセージが出てしまいます。
構文が成り立っていないのでしょうか。
 
   '変数宣言
    Dim rng, rngEnd As RANGE
  
    With ThisWorkbook.Worksheets("Sheet")
         
        'FindでT列の280を探す
        Set rng = .RANGE("T:T").Find("280")
         
            Set rngEnd = rng
         
        '280が見つからなかったら
        If (rng Is Nothing) Then
 
           MsgBox ("280はありません")
            
         Do
          'FindNextで次の値を探す
                Set rng = .RANGE("T:T").FindNext(rng)
                'ループ条件 FindNextの結果が保存した値と同じなら終了
            Loop While rng.Row <> rngEnd.Row
             
         End If
          
          
      'T列に"280"があったら、
       
       If RANGE("T:T").Value = "280" Then
        
     '280がある行の
 
     Dim r As RANGE
    Set r = Selection.EntireRow
    r.Select
      
      
     'I列とJ列をコピーする
      
     Dim Z As RANGE
      
    Set Z = Union(RANGE("I:I"), RANGE("J:J"))
    Z.Select.Copy
     
     
    '"出荷速報"シートのB列とD列にペースト
     
     Worksheets("出荷速報").Columns(1).Select
    Dim Y As RANGE
       
    Set Y = Union(RANGE("B:B"), RANGE("D:D"))
    Y.Select.Paste
     
    Else
    MsgBox ("280はありません")
     
        End If
        
 End With
  
End Sub

回答
投稿日時: 20/06/30 20:54:44
投稿者: WinArrow
投稿者のウェブサイトに移動

ザックん さんの引用:

WinArrowさん
お世話になっております。
箇条書きにしてみました。

 
掲示板に掲示するコードは、手入力せずに、コードペインからコピペしてください。
 
箇条書きした文章は、どこに?
 
ザックん さんの引用:

 If RANGE("T:T").Value = "280" Then でエラーメッセージが出てしまいます。
構文が成り立っていないのでしょうか。

>RANGE("T:T")
は、T列のセル全部ですから、このコードは実行されませんね・・・
 
ザックん さんの引用:

         Do
          'FindNextで次の値を探す
                Set rng = .RANGE("T:T").FindNext(rng)
                'ループ条件 FindNextの結果が保存した値と同じなら終了
            Loop While rng.Row <> rngEnd.Row

このDo〜Loopは、何のためのループですか?
ループの中では、何も処理がないから、空回り・・・・

投稿日時: 20/07/01 12:37:09
投稿者: ザックん

お世話になっております。
 
 
シート"sheet"のt列に"280"を探す
その多数の行を記録する
記録した行のi列とj列の値をコピーする
シート"出荷速報"のB列にシート"sheet"のi列を"B13"〜"B25"へ順に貼り付け
シート"出荷速報"のD列にシート"sheet"のJ列を"D13"〜"D25"へ順に貼り付け
 
やりたいことは上記の内容になります。
 
よろしくお願いいたします。

投稿日時: 20/07/01 12:42:50
投稿者: ザックん

修正してみたのですが、"280"の行は特定しているようですがその中でも
最終行だけコピーして、"出荷速報"に貼り付けしてしまいます。
T列に"280"がある複数の行を取得できていない様なんです。
どうしたら取得し反映できるのでしょうか。教えてください。
 
    '変数宣言
    Dim rng, rngEnd As RANGE
     
     
    'withブロック
    With ThisWorkbook.Worksheets("Sheet")
         
             'Findで1つ目を探す
              
        Set rng = .RANGE("T:T").Find("280")
         
        '見つからなかったら
        If (rng Is Nothing) Then
        MsgBox ("280はありません")
            
       Else
        
       Set rngEnd = rng
         
       Do
        
                .Cells(rng.Row, "I").Copy
             
              
                Worksheets("出荷速報").RANGE("B13").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("B14").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("B15").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("B16").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("B17").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("B18").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                 
                 
                .Cells(rng.Row, "J").Copy
                 
                 
                Worksheets("出荷速報").RANGE("D13").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("D14").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("D15").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("D16").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("D17").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                Worksheets("出荷速報").RANGE("D18").PasteSpecial Paste:=xlPasteValues, Transpose:=True
               
                           'FindNextで次の値を探す
                Set rng = .RANGE("T:T").FindNext(rng)
                'ループ条件 FindNextの結果が保存した値と同じなら終了
            Loop While rng.Row <> rngEnd.Row
               
               
     
    End If
     
         
        
 End With
  
 
  
     
  
End Sub

回答
投稿日時: 20/07/01 15:44:41
投稿者: QooApp

すごくすっごく申し訳ないんですが、
 
前回別レスで自分が投稿したプログラムにミスがありました。
Dim rng, rngEnd As RANGEの部分ですが、
 
正しくは
Dim rng As RANGE, rngEnd As RANGE
です。これに関しては勉強不足でしたすみません。
 
 
あと自分以外のコメント付けてくれている皆さんもおそらくザックんさんの意図が理解できていない箇所が多数あります。
 
作業したいことリストについてもう少し詳しく
findの使い方の時もそうですが、詳しくしっかり書いてください。
 
 

引用:
シート"sheet"のt列に"280"を探す
その多数の行を記録する
記録した行のi列とj列の値をコピーする
シート"出荷速報"のB列にシート"sheet"のi列を"B13"〜"B25"へ順に貼り付け
シート"出荷速報"のD列にシート"sheet"のJ列を"D13"〜"D25"へ順に貼り付け

 
 
全体をfindであるだけ繰り返すとのことですから、このやりたい作業の正しい解釈は
以下のようになるのではないでしょうか。
 
@シート"sheet"のT列から値"280"のある行を探す
ここは完成していると考えられる
 
Aシート"出荷速報"のB列にシート"sheet"の発見した行のI列の値を"B13"へ順に貼り付け
セルのコピー 別のセルへペースト
 
Bシート"出荷速報"のD列にシート"sheet"の発見した行のJ列の値を"D13"へ順に貼り付け
セルのコピー 別のセルへペースト
 
C貼り付け先ターゲットB13とD13を下へ1つシフトし、"最大B・D列の25行目"まで1つづつシフト
連続するセルへ代入 for文の使い方
 
Dもし、T列の探索よりも先に25行目まで到達してしまったら、14行目の値を13行目へシフト
セルのコピー 別のセルへペースト
 
E25行目の値を24行目にシフトするまでくりかえす
セルのコピー 別のセルへペースト for文
 
F25行目が空いたら改めて発見した行のI・J列の値をB・D列へ貼り付け
セルのコピー 別のセルへペースト
 
G項目@から繰り返して、もう見つからなくなったら終了する
find関数のところのwhile文がここに該当
 
この解釈あってますでしょうか。

投稿日時: 20/07/01 16:21:44
投稿者: ザックん

QooApp様
 
言葉が足らず申し訳御座いません。
やりたいことは、その通りです。
 

回答
投稿日時: 20/07/01 17:59:33
投稿者: QooApp

Dim count As Long
Dim Hairetu_I() As Variant
Dim Hairetu_J() As Variant

Redim Hairetu_I(0)
Redim Hairetu_J(0)

count = 0

〜Findの繰り返し作業のなかにここから組み込む〜

※ .Cells(rng.Row, "I").Copy と書いている箇所を下記に変更
Hairetu_I(count) = シート.Cells(Y,X座標).Value 'I列
Hairetu_J(count) = シート.Cells(Y,X座標).Value 'J列

count = count + 1
Redim Preserve Hairetu_I(count)
Redim Preserve Hairetu_J(count)

〜組み込み終わり〜

〜Findループ終わった後に貼り付ける作業

※B13 = 一番最後と仮定
貼り先.Range("B13").Value = Hairetu_I(count - 1)
貼り先.Range("B14").Value = Hairetu_I(count - 2)
貼り先.Range("B15").Value = Hairetu_I(count - 3)
貼り先.Range("B16").Value = Hairetu_I(count - 4)
・
・
・

 
電車の中で書いてるので多少のバグは自力でなんとかして欲しいです。
最初のHairetu()ですが、Asの後ろ
文字列ならそのままstring
数値ならばlongと書いてください。どんな値が入るのか私は知らないのでとりあえず何でも入りますが、危険なので。

投稿日時: 20/07/02 11:50:36
投稿者: ザックん

 
    
    Dim count As Long
    Dim Hairetu_I() As Long
    Dim Hairetu_J() As Long
    Dim k As Long
    Dim rng As RANGE, rngEnd As RANGE
     
 
    ReDim Hairetu_I(0)
    ReDim Hairetu_J(0)
 
    count = 0
     
    With ThisWorkbook.Worksheets("Sheet")
         
              
        Set rng = .RANGE("T:T").Find("280")
      
        If (rng Is Nothing) Then
        MsgBox ("280はありません")
            
       Else
        
       Set rngEnd = rng
         
      
  End If
 
        Do
                                          
        Set rng = .RANGE("T:T").FindNext(rng)
         
       For k = 7 To 50
        
        
        Hairetu_I(count) = Worksheets("sheet").Cells(k, 9).Value 'I列
        Hairetu_J(count) = Worksheets("sheet").Cells(k, 10).Value 'J列
Next
                
 
        ReDim Hairetu_I(0)
        ReDim Hairetu_J(0)
 
        count = 0
 
        count = count + 1
        ReDim Preserve Hairetu_I(count)
        ReDim Preserve Hairetu_J(count)
         
                 
        Loop While rng.Row <> rngEnd.Row
 
          
        Worksheets("出荷速報").RANGE("B13").Value = Hairetu_I(count - 1)
        Worksheets("出荷速報").RANGE("B14").Value = Hairetu_I(count - 2)
        Worksheets("出荷速報").RANGE("B15").Value = Hairetu_I(count - 3)
        Worksheets("出荷速報").RANGE("B16").Value = Hairetu_I(count - 4)
               
        Worksheets("出荷速報").RANGE("D13").Value = Hairetu_J(count - 1)
        Worksheets("出荷速報").RANGE("D14").Value = Hairetu_J(count - 2)
        Worksheets("出荷速報").RANGE("D15").Value = Hairetu_J(count - 3)
        Worksheets("出荷速報").RANGE("D16").Value = Hairetu_J(count - 4)
                          
       End With
            
  
End Sub

投稿日時: 20/07/02 11:53:34
投稿者: ザックん

お世話になっております。
QooApp様
ありがとうございます。
 
入れて修正してみましたが
 
 Hairetu_I(count) = Worksheets("sheet").Cells(k, 9).Value 'I列 で
 
オーバーフローというエラーメッセージが出てしまいました。
 
入れた場所が間違っているのでしょうか。

回答
投稿日時: 20/07/02 13:13:27
投稿者: QooApp

引用:
For k = 7 To 50
Hairetu_I(count) = Worksheets("sheet").Cells(k, 9).Value 'I列
Hairetu_J(count) = Worksheets("sheet").Cells(k, 10).Value 'J列
Next

 
これY方向のセル7行目から50行目をただひたすら同じ配列番号のセルにぶち込んでますけど大丈夫でしょうか。
 
オーバーフローの件ですが、
引用:

    〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜
        ReDim Hairetu_I(0)
        ReDim Hairetu_J(0)
 
        count = 0
        〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜〜この箇所不要
 
  
        count = count + 1
        ReDim Preserve Hairetu_I(count)
        ReDim Preserve Hairetu_J(count)
          
                  
        Loop While rng.Row <> rngEnd.Row
  
           
        Worksheets("出荷速報").RANGE("B13").Value = Hairetu_I(count - 1)
        Worksheets("出荷速報").RANGE("B14").Value = Hairetu_I(count - 2)
        Worksheets("出荷速報").RANGE("B15").Value = Hairetu_I(count - 3)
        Worksheets("出荷速報").RANGE("B16").Value = Hairetu_I(count - 4)
                
        Worksheets("出荷速報").RANGE("D13").Value = Hairetu_J(count - 1)
        Worksheets("出荷速報").RANGE("D14").Value = Hairetu_J(count - 2)
        Worksheets("出荷速報").RANGE("D15").Value = Hairetu_J(count - 3)
        Worksheets("出荷速報").RANGE("D16").Value = Hairetu_J(count - 4)
                           
       End With
             
   
End Sub

 
引用でコピーさせてもらいましたこの最初の行のRedimの2行不要です。
 
下記この記述は最初の1回だけです。
ReDim Hairetu_I(0)
ReDim Hairetu_J(0)
 
count = 0
 
これは配列の大きさを変更するために使います。
上記書式だとカッコの中に0と書いてあるので配列の大きさは1枠です。
 
配列というのは大きさの同じ変数を1つの変数にナンバリングすることで、たくさんの値をわざわざ変数宣言する手間を省くために使います。
 
たとえばお店で出てくるハンバーグはそのお店で使用するお皿に載って出てきますが、
お皿の枚数が10枚しかないのに11人に注文されたらこまりますよね。
 
なのでお皿を追加で買おうというのが
count = count + 1
ReDim Preserve Hairetu_I(count)
の箇所です。
ReDimの後ろにPreserveを記述すると
今の配列に格納さている値を保持した状態で配列を増やします。
Preserveを記述せずに2回使っていますが、宣言時、中にそれより大きなサイズのデータがある状態がまずかったのでは。

回答
投稿日時: 20/07/02 13:30:11
投稿者: QooApp

気になったので追記
 
for文の末尾、Nextですが、
Next k と使用している変数は書いておいた方がご自身が、「これ何を基準にしたループだっけ」と
忘れにくいですよ。
 
あとインデントはできれば合わせてくれると助かります。
プログラムのインデントルールはネットで調べればいくらでもでてきます。
 
このサイトでタブインデントを直接設定はできないので半角スペースで4文字分くらいのスペースを1インデントとみなして上下の文脈の構造を整理してくれた方が目が疲れにくいです。
 
前回別レスは小規模でしたらから直接回答を記載しましたが、他の方のコメントも含み理解できていない箇所をまず覚えてください。全体像の開発を希望されるならばそれは相応の対価報酬が発生します。
フリーランスのサイトで公募したほうが開発規模もご自身の悩む人件費もはるかに安くなります。
今回程度ならば報酬1万円以下でもやってくれる人いるんじゃないかと思います。
 
すくなくとも自分なら報酬1万で30分で納品します。

回答
投稿日時: 20/07/02 14:11:27
投稿者: WinArrow
投稿者のウェブサイトに移動

コード作成をううせううするのではなく、
 
処理したい内容をキチンと整理できていないと思われます。
 
 
>Worksheets("出荷速報").RANGE("B13").Value = Hairetu_I(count - 1)
このようンコードがあります。
Countで配列の中身をセルに書き出しているが、
最終的にセルの中身は、最終のCountの配列データしかセルには入っていませんね・・・・・

回答
投稿日時: 20/07/02 14:14:17
投稿者: QooApp

一応、これ関数の外枠から含めて17行あれば組めるので作ってみてください。確実に作れます。
変数宣言が開業すると最大で19行になりますが、省略形で書けば17行
下記をプログラムしてみてください。
これだけ分解して書いてバグが出たらもう助けられません。
 
関数名
Sub 自称ベストアンサー() 'たった17行でやりたいことは達成できる。
変数宣言 Long型 i _ Long型 k _ Long型配列 array_IJ()
Dim i As Long, k As Long, array_IJ() As Long
kに1を設定する
k = 1
ReDimを使ってarray_IJを(1,0)と初期化しておく
ReDim array_IJ(1, 0)
For文の頭文 i を 初期値(T列の最初に判定するべき値がくる行番号)、T列(列番号20)の最後の行目まで繰り返す
For i = 1 To Worksheets("sheet").Cells(Rows.Count, 20).End(xlUp).Row
IF文 もしもT列のi行目の値が280ならば
If (Worksheets("sheet").Cells(i, 20) = 280) Then
ReDim Preserveを使って array_IJの配列の中身を保持したまま、(1,k)の大きさまで拡張
ReDim Preserve array_IJ(1, k)
拡張が済んだ配列のI列管理をしている(0,k)にワークシート(sheet)のI列(9列目)i行目の値を入れる
array_IJ(0, k) = Worksheets("sheet").Cells(i, 9).Value
拡張が済んだ配列のJ列管理をしている(1,k)にワークシート(sheet)のJ列(10列目)i行目の値を入れる
array_IJ(1, k) = Worksheets("sheet").Cells(i, 10).Value
変数 k に 1足す
k = k + 1
If文終わり
End If
For文末尾分 i
Next i
For 文 i の初期値を13にする 16までループする
For i = 13 To 16
ワークシート出荷速報のセル位置 2列目(B列のこと) i行目に array_IJ(0,k-(i-12))を代入
Worksheets("出荷速報").Cells(i, 2).Value = array_IJ(0, k - (i - 12))
ワークシート出荷速報のセル位置 4列目(D列のこと) i行目に array_IJ(1,k-(i-12))を代入
Worksheets("出荷速報").Cells(i, 4).Value = array_IJ(1, k - (i - 12))
For文末尾分 i
Next i
関数終わり
End Sub

回答
投稿日時: 20/07/02 15:05:43
投稿者: WinArrow
投稿者のウェブサイトに移動

配列の最異臭の値しか鉄騎されないことは、自分でもわかっていますよね?
  

引用:
シート"出荷速報"のB列にシート"sheet"のi列を"B13"〜"B25"へ順に貼り付け
シート"出荷速報"のD列にシート"sheet"のJ列を"D13"〜"D25"へ順に貼り付け

 
 この説明と実際のコードが整合していません。
文章段階であいまいな表現をしていると、コードは更にわかりにくくないます。
  
文章をわかりやすく書くと
 シート"sheet":T列セルの値が"280"のデータを検索し
  ・I列セルの値を出荷速報シートのB列セルへ転記したい。
   ・J列セルの値を出荷速報シートのD列セルへ転記したい。
   なお、出荷速報シートの先頭行を13とする。
  
※B25とかD25は不要。
最終は、データ件数によって決まるので、記述するとわかりにくくする。
  
以下は、参考コードです。
Sub 転記()
Dim sht1 As Worksheet, sht2 As Worksheet
 Dim tCELL As Range, tROW As Long, bROW As Long, dROW As Long
   
   
     Set sht1 = Sheets("sheet")
     Set sht2 = Sheets("出荷速報")
   
     Set tCELL = sht1.Columns("T").Find(what:="280")
     If tCELL Is Nothing Then
         MsgBox "該当なし": Exit Sub '見つからなかったら、即処理中止
     End If
     tROW = tCELL.Row
       
     Do
         bROW = sht2.Range("B" & sht2.Rows.Count).End(xlUp).Row + 1
         If bROW < 13 Then bROW = 13
         sht2.Cells(bROW, "B").Value = sht1.Cells(tCELL.Row, "I").Value
                   
         dROW = sht2.Range("D" & sht2.Rows.Count).End(xlUp).Row + 1
         If dROW < 13 Then dROW = 13
         sht2.Cells(dROW, "D").Value = sht1.Cells(tCELL.Row, "J").Value
       
         Set tCELL = sht1.Columns("T").FindNext(tCELL)
     Loop Until tCELL.Row = tROW
       
   
End Sub
  

回答
投稿日時: 20/07/02 15:07:41
投稿者: WinArrow
投稿者のウェブサイトに移動

追加コメント
 
抽出データを配列に入れる必要もありません。
従っ配列を用意する必要もありません。

回答
投稿日時: 20/07/02 16:20:29
投稿者: WinArrow
投稿者のウェブサイトに移動

ごめんなさい
文章の入力ミスがありました。
訂正します。
>配列の最異臭の値しか鉄騎されないことは、自分でもわかっていますよね?

配列の最終セルの値しか転記されないことは、自分でもわかっていますよね?
 
 

投稿日時: 20/07/03 18:04:21
投稿者: ザックん

 WinArrow様
 QooApp様
詳細まで教えていただきありがとうございます。
 
WinArrow様にアドバイス頂いた内容で動作してみました。
 
”280”がある複数の列のI列とJ列を"出荷速報"に転記することができました。"出荷速報"の
B列には、何度試しても問題なく13行目〜転記するのですが、D列が27行目〜に転記されてしまいます。
何処が悪いのか分からない状態です。
教えていただけないでしょうか。よろしくお願いいたします。
 

投稿日時: 20/07/03 18:05:34
投稿者: ザックん

こちらが入力した内容です。
 
    Dim sht1 As Worksheet, sht2 As Worksheet
        
    Dim tcell As RANGE, trow As Long, brow As Long, drow As Long
     
    Set sht1 = Sheets("sheet")
     
    Set sht2 = Sheets("出荷速報")
     
    Set tcell = sht1.Columns("T").Find(WHAT:="280")
    If tcell Is Nothing Then
    MsgBox "フライス完了品なし": Exit Sub 'なかったら処理停止
    End If
    trow = tcell.Row
     
    Do
     
    brow = sht2.RANGE("b" & sht2.Rows.count).End(xlUp).Row + 1
     
    If brow < 13 Then brow = 13
     
    sht2.Cells(brow, "B").Value = sht1.Cells(tcell.Row, "I").Value
     
     
    drow = sht2.RANGE("d" & sht2.Rows.count).End(xlUp).Row + 1
        
    If drow < 13 Then drow = 13
     
    sht2.Cells(drow, "d").Value = sht1.Cells(tcell.Row, "J").Value
     
    Set tcell = sht1.Columns("T").FindNext(tcell)
     
     
 Loop Until tcell.Row = trow
  
 
 
 
End Sub

回答
投稿日時: 20/07/03 23:05:53
投稿者: WinArrow
投稿者のウェブサイトに移動

>D列が27行目〜に転記されてしまいます
セルD26に何か入っているのでしょう。
 
例えば
長さ=0 のスペースが入っているかもしれません。

回答
投稿日時: 20/07/04 10:00:40
投稿者: simple

ステップ実行して
drow
がどうなっているのか観察してみては?
それは想定しているものになっていますか?
なっていないとすると、どうしてなのか考えてみては?
 
既に回答いただいていますが、
解決に至るプロセスといったものにも考えを馳せていただきたい。

投稿日時: 20/07/04 10:47:22
投稿者: ザックん

WinArrow様
 
数式が入っていたのでこの様なことになっていました。
アドバイスありがとうございました。
 
QooApp様
 
色々とアドバイスありがとうございました。
 
simple様
 
ご協力頂いた皆様より、同様のご指摘を頂きました。
もっと、具体的に詳細に頭の中を整理して取り組んでいきます。
今後もアドバイス宜しくお願い致し致します。