Excel (VBA)

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

 
(指定なし : 指定なし)
該当するデータを行ごと別シートに書き出したいです
投稿日時: 22/08/03 22:18:49
投稿者: y_0770

大変お世話になっております。
元データ(Sheet1)をE列の数値を基準とし、各々のシートに振り分けをしたいです。
元データ(Sheet1)のE列の数値は1つの数値(例えば、20、30、35、40など)ですが、貼り付け先シートは例えば、30・35(30と35の数値)を混在して振り分ける必要があります(30が65行、35が35行あれば、30・35のシートは100行となります)。単独のものもあります(20のみ、60のみ等です)
以下のコードがありますが、どのように修正をすれば良いでしょうか…。
それから出来ましたら、セルA●からF●ではなく、列の指定なく行を貼り付けを行いたいです。
 
Sub test1()
  Dim i As Long
  Dim lastRow As Long
  Dim mySh As Worksheet
  Dim myFlg As Boolean
  Dim myRow As Long
  Dim myKey As String
 
    lastRow = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To lastRow
        '----振り分け先のシートが存在するか否かをチェック
        For Each mySh In Worksheets
            myFlg = False
            myKey = Worksheets("Sheet1").Range("E" & i).Value
            If mySh.Name = myKey Then
                myFlg = True
                mySh.Cells.Delete
                Exit For
            End If
        Next mySh
        '----振り分け先のシートがなかったらシートを追加する
        If myFlg = False Then
            ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey
        End If
 
        '----列見出しをコピー&貼り付け
        Worksheets("Sheet1").Range("A1:C1").Copy Worksheets(myKey).Range("A1")
    Next i
 
        '----データを転記する
        For i = 2 To lastRow
            myKey = Worksheets("Sheet1").Range("E" & i).Value
            If myKey <> "" Then
                myRow = Worksheets(myKey).Range("A" & Rows.Count).End(xlUp).Row + 1
                Worksheets("Sheet1").Range("A" & i & ":F" & i).Copy _
                Worksheets(myKey).Range("A" & myRow & ":F" & myRow)
            End If
        Next i
End Sub
 
 
元データ(Sheet1)
 
A列  B列       C列          D列  E列  F列
 
25987    2022/7/13    記念すべき素晴らしい年    1    20    888
32458    2022/7/14    問題ないと判断        2    30    999
50289    2022/7/15    そのため私あて        3    50    1110
66854    2022/7/16    極めて困難な状況       4    20    1221
45876    2022/7/17    日本では問題ない       5    30    1332
69874    2022/7/18    素晴らしい対応        6    50    1443
25874    2022/7/19    訪問し対応          7    55    1554
69854    2022/7/20    アメリカではどうか      8    99    1665
22547    2022/7/21    フランス政府         9    10    1776
33258    2022/7/22    ドイツは参加しなかった    10    60    1887
56987    2022/7/23    ロシアの全土で        11    40    1998
54785    2022/7/24    解決した           12    45    2109
33698    2022/7/25    温暖化等の環境問題      13    60    2220
 
大変お手数ですが、ご回答をお待ちしております。
どうぞ宜しくお願い申し上げます。

回答
投稿日時: 22/08/04 05:31:06
投稿者: WinArrow
投稿者のウェブサイトに移動

掲示のコードでは、E列の値でシートの存在をチェックしていますが、
これでは、「30と35]のような場合は対応できませんね・・・・
 
まず、複写後のシートの一覧表を作成し、
その一覧表に基づき、振分する必要があります。
 
もう一つは、オートフィルタを活用することをお勧めします。

回答
投稿日時: 22/08/04 09:52:10
投稿者: Suzu

シートの存在確認をして、セルの中身をクリアするのであれば、
初めからワークシートを追加する仕様でも良いと思いました。
 
振り分けの為に、オートフィルターを使用するとし、
フィルターの値を得るのに、E列の値を 別シートにコピーし 重複の削除 を使用し一意の値を取得
その値を元に、ワークシート作成と、フィルターにて抽出する値を指定しています。
 
混在については、作成されたシートど ちらか から どちらか へ コピペすれば良いでしょう。
 
 
Sub TEST2()
 
Dim rng As Range
 
'オートフィルター解除
Worksheets("Sheet1").AutoFilterMode = False
 
'E列 重複無し 値 取得の為の作業用シート List 作成
Worksheets.Add(Before:=Worksheets("Sheet1")).Name = "List"
 
'E列値を Listにコピー
Worksheets("Sheet1").Range("E2:E" & Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, 5).End(xlUp)).Copy Worksheets("List").Range("A1")
'List の値から 重複の削除実行
Worksheets("List").UsedRange.RemoveDuplicates Columns:=1, Header:=xlNo
 
For Each rng In Worksheets("List").Range("A1").CurrentRegion
  'List の値を元に、ワークシート作成
  Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = rng.Value
  'List の値を元に、オートフィルター を E列に適用。結果を作成した同名シートに貼付
  Worksheets("Sheet1").Range("A1").AutoFilter Field:=5, Criteria1:=rng.Value
  Worksheets("Sheet1").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
         Worksheets(CStr(rng.Value)).Range("A1")
Next
' Worksheets("List").Delete
Worksheets("Sheet1").AutoFilterMode = False
End Sub

回答
投稿日時: 22/08/04 11:54:39
投稿者: sk

引用:
元データ(Sheet1)をE列の数値を基準とし、各々のシートに振り分けをしたいです。

引用:
貼り付け先シートは例えば、30・35(30と35の数値)を混在して振り分ける
必要があります(30が65行、35が35行あれば、30・35のシートは100行となります)。
単独のものもあります(20のみ、60のみ等です)

引用:
myKey = Worksheets("Sheet1").Range("E" & i).Value
If mySh.Name = myKey Then

「混在して振り分ける」シートの命名規則と具体例を
明記されることをお奨めします。
 
引用:
'----振り分け先のシートがなかったらシートを追加する
If myFlg = False Then
    ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey
End If

また、そもそもの「混在させるか、させないか」の条件とは
具体的にどのようなものなのでしょうか。
 
少なくとも「振り分け先のシートがなかった」場合において、
今のままでは「混在して振り分ける」シートを追加しようがないでしょう。

回答
投稿日時: 22/08/04 12:51:28
投稿者: WinArrow
投稿者のウェブサイトに移動

E列の値と対応うる複写先シートの対応表の作成をお勧めします。
 

 
20 A
21 B
22 A
23 C
この例は、20と22は、シートAに複写するという意味です。
シートAは、仮の名前なので、何でもよい
 

投稿日時: 22/08/04 21:33:17
投稿者: y_0770

WinArrow 様
sk 様
 
大変お世話になっております。
ご連絡を頂きまして有難うございました。
 
どの番号が単独でひとつのシートに貼り付け、どの番号が混在し,ひとつのシートにまとめるのかが、まだ明確に決まっていないため決まり次第近日中にコメントをさせて頂きます…。
 
現在の質問が曖昧で申し訳ございませんでした…。
 
お時間を頂きまして、本当に有難うございます。
引き続きどうぞ宜しくお願い申し上げます。
 
P.S ; 仕事をしており、お返事が遅くなりまして申し訳ございませんでした…。

投稿日時: 22/08/04 21:53:43
投稿者: y_0770

Suzu 様
 
大変お世話になっております。
ご連絡を下さいまして有難うございました。
  
ご案内を頂きましたコードで今試してみました。
Listも作成され分かりやすいですし、今までE列の番号に該当するシートを手作業で作成、フィルターをかけコピー&ペーストをしていたため、この労力が省けかなり楽になります…。
 
 >混在については、作成されたシートど ちらか から どちらか へ コピペすれば良いでしょう。
有難うございます。一旦そのようにさせて頂きます!
  
お時間を頂戴致しまして、コードをお送り下さいまして、感謝の気持ちで一杯です…!
 
いつか自分でマクロが組めるように、ご案内を下さいましたコードを大切にし、勉強をさせて頂きます。
 
ご親切を頂きまして、心より感謝申し上げます。
引き続きどうぞ宜しくお願い申し上げます。
  
P.S ; 仕事をしており、お返事が遅くなりまして大変申し訳ございませんでした…。

回答
投稿日時: 22/08/05 05:54:33
投稿者: WinArrow
投稿者のウェブサイトに移動

御在する場合のシートの件は、別にして
E列データを名前とするシートの存在確認をしていますが、
E列には存在しないシートが既に存在した場合は、
実行前のシートが残ってしまいます。
存在チェックよりも、不要シート削除の方が確実ではないでしょうか?

回答
投稿日時: 22/08/05 18:57:37
投稿者: WinArrow
投稿者のウェブサイトに移動

(1)E列データと複写先シート名のテーブルを使います。
 
最初に(1)のシートを完成させてください。
A列を手入力する。変更可能
サンプルデータ:シート名="TABLE"
A列   B列
シート名    E列KEY
10    10
20    20
30    30
40.45    40
40.45    45
50.55    50
50.55    55
60    60
99    99
 
 
処理コード・・・・参考です。

Sub サンプル()
Dim sht As Worksheet, BK1 As Workbook
Dim AX As Long, COLCNT As Long
Dim myKEYS
Dim mykey
Dim BX As Long, Errflg As Boolean, RX As Long
Dim myDIC As Object
Dim eKEY1 As String, eKEY2, Ex As Long

    Set BK1 = ThisWorkbook
    
    With BK1
        On Error Resume Next
        Set sht = .Sheets("TABLE")
        If Err.Number <> 0 Then
            Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
            sht.Name = "TABLE"
            sht.Range("A1:B1").Value = Split("シート名,E列KEY", ",")
            sht.Columns("A").NumberFormatLocal = "@"
        End If
        On Error GoTo 0
        Application.DisplayAlerts = False
        For Each sht In .Sheets
            If Not (sht.Name = "Sheet1" Or sht.Name = "TABLE") Then
                sht.Delete
            End If
        Next
        
        Errflg = False
        With .Sheets("Sheet1")
            For RX = 2 To .Range("E" & .Rows.Count).End(xlUp).Row
                If WorksheetFunction.CountIf(BK1.Sheets("TABLE").Columns("B"), .Cells(RX, "E").Value) = 0 Then
                    Errflg = True
                    BK1.Sheets("TABLE").Range("B" & BK1.Sheets("Sheet1").Rows.Count).End(xlUp).Offset(1).Value = .Cells(RX, "E").Value
                End If
            Next
        End With
        
        If Errflg Then
            MsgBox "「TABLE」シートに存在しないキーがあります。"
            Exit Sub
        End If
        With BK1.Sheets("TABLE")
            .UsedRange.Sort key1:=.Range("A1"), order1:=xlAscending, _
                        key2:=.Range("B1"), order2:=xlAscending, _
                        Header:=xlYes
            
            'AutoFilter 検索キー取得
            Set myDIC = CreateObject("Scripting.Dictionary")
            For AX = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
                eKEY1 = .Cells(AX, "A").Value
                Ex = 0
                ReDim eKEY2(Ex)
                If Not myDIC.Exists(eKEY1) Then
                    For BX = AX To .Range("A" & .Rows.Count).End(xlUp).Row
                        If .Cells(BX, "A").Value = eKEY1 Then
                            ReDim Preserve eKEY2(Ex)
                            eKEY2(Ex) = CStr(.Cells(BX, "B").Value)
                            Ex = Ex + 1
                        End If
                    Next
                    myDIC.Add eKEY1, eKEY2
                End If
            Next
            
            myKEYS = myDIC.keys
            'myDICからAutoFilter シート複写
            For AX = LBound(myKEYS) To UBound(myKEYS)
                eKEY2 = myDIC.Item(myKEYS(AX))
                With BK1.Sheets("sheet1").UsedRange
                    .AutoFilter field:=5, Criteria1:=eKEY2, Operator:=xlFilterValues
                    .Copy
                    Set sht = BK1.Sheets.Add(after:=BK1.Sheets(BK1.Sheets.Count))
                    sht.Name = myKEYS(AX)
                    sht.Range("A1").Select
                    sht.Paste
                    sht.UsedRange.EntireColumn.AutoFit
                    Application.CutCopyMode = False
                    .AutoFilter
                End With
            Next
                    
        End With
        
        
        
        
    End With
    Exit Sub
    

End Sub

 
 

投稿日時: 22/08/06 12:27:56
投稿者: y_0770

WinArrow 様..!
 
大変お世話になっております。
ご連絡を下さいまして本当に有難うございました..!
 
ご教示を頂きましたコードで今実行をさせて頂きました!
あっという間に作業が完了し、感動致しました..!
 
素晴らしいコードを組んで頂きまして、深く感謝申し上げます..!
 
WinArrow 様から、ご教示を下さいましたコードを大切に致します…。
いつか自身でマクロを作成したいため、組んで頂きましたコードを元に勉強を致します。
 
ご親切と貴重なお時間を頂きまして、感謝の気持ちで一杯です…!
今後共、どうぞ宜しくお願い申し上げます!
   
P.S ; 仕事の都合でお礼のお返事が遅くなりまして、大変申し訳ございませんでした…。