Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2578 / 13645 ツリー ←次へ | 前へ→

【67126】データの条件付コピー ベニー 10/11/7(日) 14:36 質問[未読]
【67129】Re:データの条件付コピー Hirofumi 10/11/7(日) 16:26 発言[未読]
【67130】Re:データの条件付コピー Hirofumi 10/11/7(日) 16:47 回答[未読]
【67131】Re:データの条件付コピー Hirofumi 10/11/7(日) 16:48 回答[未読]
【67133】Re:データの条件付コピー kanabun 10/11/7(日) 23:50 発言[未読]
【67136】Re:データの条件付コピー kanabun 10/11/8(月) 9:20 発言[未読]

【67126】データの条件付コピー
質問  ベニー  - 10/11/7(日) 14:36 -

引用なし
パスワード
   A 列 B列
=========
1 XXX
1 XXX
1 XXX
1 XXX
2 XXX
2 XXX
2 XXX
2 XXX
3 XXX
3 XXX
3 XXX

※ XXXは任意の文字データ


上記のようなデータがシート1にあり、これをもとに
シート2には

A 列 B列
=========
1 XXX
1 XXX
1 XXX
1 XXX

シート3
A 列 B列
=========
2 XXX
2 XXX
2 XXX
2 XXX

シート4には
A 列 B列
=========
3 XXX
3 XXX
3 XXX

となるようにしたいのです。
今作成している物はとりあえず、シート2〜4にシート1をコピーして
コピー後の個々のシートのB列に対して、シート番号 - 1 でなければ
削除としています。
シート1でB列が1の部分だけシート2、B列が2の部分だけシート3
というように書くにはどう書けばよいのでしょうか。
後学のために教えていただけると幸いです。

【67129】Re:データの条件付コピー
発言  Hirofumi  - 10/11/7(日) 16:26 -

引用なし
パスワード
   >となるようにしたいのです。
>今作成している物はとりあえず、シート2〜4にシート1をコピーして
>コピー後の個々のシートのB列に対して、シート番号 - 1 でなければ
>削除としています。
>シート1でB列が1の部分だけシート2、B列が2の部分だけシート3
>というように書くにはどう書けばよいのでしょうか。
>後学のために教えていただけると幸いです。

B列とA列を間違えているのかな?

【67130】Re:データの条件付コピー
回答  Hirofumi  - 10/11/7(日) 16:47 -

引用なし
パスワード
   こんなのでは?

Sheet1には、列見出しが有る物とします
データは、A列〜B列の2列とし、転記するグループは、A列に有るとします

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜B列)
  Const clngColumns As Long = 2
  'グループの有る列(A列のA列からの列Offset)
  Const clngGroup As Long = 0
  '結果出力の先頭位置
  Const cstrTop As String = "A1"
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngCount As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim rngHeader As Range
  Dim vntGroup As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngGroup).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データをA列で整列
    .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(, clngGroup), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'A列データを配列に取得
    vntGroup = .Offset(1, clngGroup).Resize(lngRows + 1).Value
    '列見出し範囲を取得
    Set rngHeader = .Resize(, clngColumns)
  End With
  
  '仮に結果と元表を同じにして置く
  Set rngResult = rngList
  '注目値の位置を記録
  lngTop = 1
  'データ行数のカウント初期値
  lngCount = 1
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      '出力シートを設定
      GetSheets CStr(vntGroup(lngTop, 1)), cstrTop, _
            rngResult, rngHeader
      'データを転記
      rngList.Offset(lngTop).Resize(lngCount, clngColumns).Copy _
          Destination:=rngResult.Offset(1)
      '注目値の位置を記録
      lngTop = i
      'データ行数のカウント初期値に
      lngCount = 1
    Else
      'データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i

  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
  Set rngHeader = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke

End Sub

Private Sub GetSheets(strName As String, _
            strTop As String, _
            rngResult As Range, _
            rngHeader As Range)
  
  Dim i As Long
  Dim lngRows As Long
  Dim wksMark As Worksheet
  
  'シートの存在確認
  For Each wksMark In Worksheets
    If StrComp(wksMark.Name, strName, vbTextCompare) = 0 Then
      Exit For
    End If
  Next wksMark
  'もし、シートが無いなら
  If wksMark Is Nothing Then
    'シートを追加して、シート名を設定
    Set wksMark = Worksheets.Add(After:=rngResult.Parent)
    wksMark.Name = strName
  End If
  
  With wksMark.Range(strTop)
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows >= 1 Then
      'データを消去
      .Offset(1).Resize(lngRows, rngHeader.Columns.Count).ClearContents
    Else
      '列見出しを出力
      rngHeader.Copy Destination:=.Offset
    End If
    '出力位置を設定
    Set rngResult = .Cells(1, 1)
  End With
  
  Set wksMark = Nothing
      
End Sub

【67131】Re:データの条件付コピー
回答  Hirofumi  - 10/11/7(日) 16:48 -

引用なし
パスワード
   ごめん

Private Sub DataSort(rngScope As Range, _
          rngKey As Range, _
          Optional lngOrientation As Long = xlTopToBottom)

  rngScope.Sort _
      Key1:=rngKey, Order1:=xlAscending, _
      Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
      Orientation:=xlTopToBottom, SortMethod:=xlStroke

End Sub

は消し忘れです
削除して下さい

【67133】Re:データの条件付コピー
発言  kanabun  - 10/11/7(日) 23:50 -

引用なし
パスワード
   ▼ベニー さん:
おじゃまします

>シート1でB列が1の部分だけシート2、B列が2の部分だけシート3
>というように

フィルタオプションの設定を使って同じ番号(数字)だけ抽出コピー
する方法もありますよ

(前提) 1行目は列見出しとします
(Step 1) A列に どんな番号があるか→リストにしておきます
(Step 2) 番号リスト順に「フィルタオプション」かけて別シートに抽出します

Sub Try1()
 Dim WS2 As Worksheet
 Dim rr As Range, aList As Range, c As Range
 Dim n As Long, nSheet As Long
 
 With Worksheets("Sheet1")
  Set rr = .Range("A1").CurrentRegion
  rr.Columns(1).AdvancedFilter xlFilterCopy, , .Range("BB1"), True
  Set aList = .Range("BB1").CurrentRegion
 End With
 nSheet = 1
 For Each c In Intersect(aList, aList.Offset(1))
  nSheet = nSheet + 1
  n = Worksheets.Count
  If nSheet > n Then
    Set WS2 = Worksheets.Add(After:=Worksheets(n))
  Else
    Set WS2 = Worksheets(nSheet)
    WS2.UsedRange.ClearContents
  End If
  rr.AdvancedFilter xlFilterCopy, aList.Resize(2), WS2.Range("A1")
  WS2.Name = aList.Item(2).Value     '抽出した番号をシート名に
  WS2.Columns.AutoFit          '列幅 オートフィット
  aList.Item(nSheet + 1).Copy aList.Item(2)
  Set WS2 = Nothing
 Next
 aList.Clear
End Sub

【67136】Re:データの条件付コピー
発言  kanabun  - 10/11/8(月) 9:20 -

引用なし
パスワード
   ▼ベニー さん:

少し修正しました

Sub Try2()
 Dim WS2 As Worksheet
 Dim rr As Range, aList As Range, c As Range
 Dim n As Long, nSheet As Long
 
 With Worksheets("Sheet1")  'A列の一意な番号リストを作成(範囲aList)
  Set rr = .Range("A1").CurrentRegion
  rr.Columns(1).AdvancedFilter xlFilterCopy, , .Range("BB1"), True
  Set aList = .Range("BB1").CurrentRegion
 End With
 
 For nSheet = 2 To aList.Count
  n = Worksheets.Count
  If nSheet > n Then        'シートがないとき
    Set WS2 = Worksheets.Add(After:=Worksheets(n))
  Else
    Set WS2 = Worksheets(nSheet) 'シートがあるとき
    WS2.UsedRange.ClearContents
  End If              '抽出Copy
  rr.AdvancedFilter xlFilterCopy, aList.Resize(2), WS2.Range("A1")
  WS2.Name = aList.Item(2).Value  '抽出した番号をSheet名に
  WS2.Columns.AutoFit        '列幅AutoFit
  aList.Item(nSheet + 1).Copy aList.Item(2)
  Set WS2 = Nothing
 Next
 aList.Clear
End Sub

2578 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free