[[20221203011958]]　『X1の人だけ別シートb列に隙間なく詰める』（八家）　ページの最後に飛ぶ

『X1の人だけ別シートb列に隙間なく詰める』（八家）

～sheet1～

  A	B	       C　
1 X1	芹沢鴨		
2 X1	近藤勇		
3 X5    新見錦
4 X4    斎藤一
5 X6    土方歳三
6 X5    大野右仲
7 X4    相馬主計
8 X1    山南敬助
9 X1    伊東甲子太郎
10 X6	沖田総司

～sheet2～

いつもお世話になっております。
質問したく投稿しました。
上記のようなシートが2枚あるとします。
ボタンを押したら、X1と振り分けられた人物だけsheet2のb列に隙間なく詰めるマクロを考えています。
一応、できたのですが、

：：：：：：：：：：：：：
～sheet2～

  A	B	       C　
1 X1	芹沢鴨		
2 X1	近藤勇		
3 
4 
5 
6 
7 
8 X1    山南敬助
9 X1    伊東甲子太郎
10 
：：：：：：：：：：：：：
このように歯抜けになってしまいました。

以下、コード。
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
Sub 抜き取り()

    Dim lastRow As Long, i As Long
    Dim c0 As Worksheet, c1 As Worksheet

    Set c0 = Sheets("Sheet1")
    Set c1 = Sheets("c1")

    For i = 1 To 100
        If c0.Cells(i + 1, 1).Value = "X1" Then
            c1.Cells(i, 2).Value = c0.Cells(i + 1, 2).Value
        End If
    Next i

End Sub
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：
：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：

最終行を拾うというコードを拝借して、もう一度つくりなおしましたが・・・
：：：：：：：：：：：：：
～sheet2～

  A	B	       C　
1 X1	芹沢鴨		
2 X1    伊東甲子太郎
：：：：：：：：：：：：：

このように、歯抜けはなくなりましたが、頭と尻だけしか拾えない結果になってしまいました。

    Dim lastRow As Long, i As Long
    Dim c0 As Worksheet, c1 As Worksheet

    Set c0 = Sheets("Sheet1")
    Set c1 = Sheets("c1")
    lastRow = c1.Cells(Rows.Count, 1).End(xlUp).Row

    t = 0
    For i = 1 To 100
        If c0.Cells(i + 1, 1).Value = "X1" Then
            c1.Cells(t + 1, 2).Value = c0.Cells(i + 1, 2).Value
        End If
        t = lastRow
    Next i

前置きが長くなりましたが、要は、歯抜けがなくなり、かつ、全てのデータが拾える
コードを作りたいのですが、どうしてもこれ以上は思いつきませんでした。

すいませんが、ご教授をお願いいたします。

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

ソートすれば良いんじゃない
もしくは、オートフィルタで取りだす。
（ソート） 2022/12/03(土) 02:57:17

こう

    t = 0
    For i = 1 To 100
        If c0.Cells(i + 1, 1).Value = "X1" Then
            c1.Cells(t + 1, 2).Value = c0.Cells(i + 1, 2).Value
            t = t + 1
        End If
    Next i

または

    t = c1.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To 100
        If c0.Cells(i + 1, 1).Value = "X1" Then
            c1.Cells(t + 1, 2).Value = c0.Cells(i + 1, 2).Value
        End If
        t = c1.Cells(Rows.Count, 1).End(xlUp).Row
    Next i

もうすこしかえて

    For i = 1 To 100
        If c0.Cells(i + 1, 1).Value = "X1" Then
　　　　    t = c1.Cells(Rows.Count, 1).End(xlUp).Row
            c1.Cells(t + 1, 2).Value = c0.Cells(i + 1, 2).Value
        End If
    Next i

（さんぷる） 2022/12/03(土) 06:54:01

テキトーですが。
ソートさんの案でつくってみました

 Sub ソート()
     Dim ws1 As Worksheet, ws2 As Worksheet
     Dim LastR As Long, cnt As Long
     Set ws1 = Worksheets("Sheet1")
     Set ws2 = Worksheets("Sheet2")
     LastR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
     cnt = WorksheetFunction.CountIf(ws1.Range("A1").Resize(LastR), "X1")
     ws1.Range("A1").Resize(LastR, 2).Sort Key1:=ws1.Range("A1"), Order1:=xlAscending
     ws1.Range("A1").Resize(cnt, 2).Copy ws2.Range("A1")
 End Sub

 Sub オートフィルタ()
     Dim ws1 As Worksheet, ws2 As Worksheet
     Set ws1 = Worksheets("Sheet1")
     Set ws2 = Worksheets("Sheet2")
     With ws1
         .Rows(1).Insert
         .Range("A1") = "見出し"
         .Range("A1").AutoFilter 1, "X1"
         .Range("A1").CurrentRegion.Copy ws2.Range("A1")
         .Rows(1).Delete
         ws2.Rows(1).Delete
     End With
 End Sub
（フォーキー） 2022/12/03(土) 08:56:03

 おはようございます

 ＞このように歯抜けになってしまいました。

 大丈夫!! 、皆やります。(笑)

 ＞このように、歯抜けはなくなりましたが、頭と尻だけしか拾えない結果に 
 ＞なってしまいました。

 う～ん、こっちはあまりしないな…きっと

 八家さん...頑張ってVBAのお勉強をされているご様子で
 お手伝いにになるかわかりませんが

 一応、できたのですが、の最初のマクロだと
 Sheet2に、下記のように転記され

    |[A]|[B]         
 [1]|   |近藤勇      
 [2]|   |            
 [3]|   |            
 [4]|   |            
 [5]|   |            
 [6]|   |            
 [7]|   |山南敬助    
 [8]|   |伊東甲子太郎

 最終行を拾うというコードを拝借して、もう一度つくりなおしましたが・・・
 だと、Sheet2に、下記のように転記されるような気がしますけど

    |[A]|[B]         
 [1]|   |近藤勇      
 [2]|   |伊東甲子太郎

 マクロの一部を見ると  i+1 にしてあるのは
 もしかして、1行目には見出しがあるってことですか？

 ↓ここ
 c0.Cells(i + 1, 2).Value

 それと…少々気になる点ですが^^;

 ↓ここ…中途半端でww
 Set c0 = Sheets("Sheet1")
 Set c1 = Sheets("c1")

 質問する時は、揃える

 フォーキーさんのように統一
 Set ws1 = Worksheets("Sheet1")
 Set ws2 = Worksheets("Sheet2")

 もしくは、シート名を変更したものに
 Set c0 = Sheets("c0")
 Set c1 = Sheets("c1")

 もしくは、インデックスで揃えましょうよ
 Set c0 = Sheets(1)                                                                  
 Set c1 = Sheets(2)

 本題へ…見出しが1行目が無いとして
 最初のマクロで、B列だけ転記するなら

 Sub Sample1()

    Dim lastRow As Long, i As Long, n As Long
    Dim c0 As Worksheet, c1 As Worksheet
    Set c0 = Sheets(1)
    Set c1 = Sheets(2)
    lastRow = c0.Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lastRow
        If c0.Cells(i, 1).Value = "X1" Then
            n = n + 1
            c1.Cells(n, 2).Value = c0.Cells(i, 2).Value
        End If
    Next i

 End Sub

 A列、B列の両方を、配列を使用してお引越し
 こちらの結果は、フォーキーさんが提案された
 二つのマクロと同じになります。

 Sub Sample2()

    Dim c0 As Worksheet, c1 As Worksheet
    Dim lastRow As Long
    Dim i As Long, q As Long, n As Long
    Dim storage() As Variant, extraction() As Variant
    Set c0 = Sheets(1)
    Set c1 = Sheets(2)
    lastRow = c0.Cells(Rows.Count, 1).End(xlUp).Row
    ReDim storage(lastRow, 2)
    ReDim extraction(1 To lastRow, 1 To 2)
    storage = c0.Range("A1:B" & lastRow).Value

    n = 1
    For i = 1 To UBound(storage, 1)
        If storage(i, 1) = "X1" Then
            For q = 1 To UBound(storage, 2)
                extraction(n, q) = storage(i, q)
            Next q
            n = n + 1
        End If
    Next i

    c1.Range("A1").Resize(n, UBound(extraction, 2)) = extraction

 End Sub

（あみな） 2022/12/03(土) 11:05:54

返信遅れてすみません
ソート様、サンプル様、フォーキー様、あみな様
こんなにご丁寧なご回答ありがとうございます。
おかげさまでうまくできました！
現場で大事に使わせていただきたいと思います。
本当にありがとうございました。

（八家） 2022/12/03(土) 13:06:44

 質問にも回答できないのですか？
 上手く行くマクロと、上手く行かないマクロの場合とが
 あると思いますが....

（あみな） 2022/12/03(土) 15:06:23

あみなさま
大変失礼いたしました。

＞マクロの一部を見ると i+1 にしてあるのは

 もしかして、1行目には見出しがあるってことですか？
そうです。

＞↓ここ…中途半端でww

 Set c0 = Sheets("Sheet1")
 Set c1 = Sheets("c1")
 質問する時は、揃える
確かにそうですね、以後気を付けます。

＞上手く行くマクロと、上手く行かないマクロの場合とが

 あると思いますが....
皆さんのマクロを勉強させてもらって頂きましたので大丈夫です。

ここまで親身になってくれたのに不躾な返答失礼しました。以後気を付けます。

（八家） 2022/12/03(土) 20:09:44

 >質問する時は、揃える?
（?） 2022/12/03(土) 20:32:37

というか変数名がおかしく無いですか？
ws とか sh とかが普通じゃない？
（感想） 2022/12/03(土) 20:44:12

コメント返信：

[ 一覧(最新更新順) ]

[[20221203011958]] 『X1の人だけ別シートb列に隙間なく詰める』（八家） ページの最後に飛ぶ

[[20221203011958]]　『X1の人だけ別シートb列に隙間なく詰める』（八家）　ページの最後に飛ぶ