Excel VBA質問箱 IV

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

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


3708 / 13644 ツリー ←次へ | 前へ→

【60551】一つのシートから、複数のシートの作成 nokubo 09/2/27(金) 16:12 質問[未読]
【60554】Re:一つのシートから、複数のシートの作成 ponpon 09/2/27(金) 22:19 発言[未読]
【60556】Re:一つのシートから、複数のシートの作成 Street 09/2/27(金) 22:36 回答[未読]
【60569】Re:一つのシートから、複数のシートの作成 nokubo 09/3/2(月) 11:02 お礼[未読]
【60557】Re:一つのシートから、複数のシートの作成 kanabun 09/2/28(土) 0:51 発言[未読]
【60558】Re:一つのシートから、複数のシートの作成 Hirofumi 09/2/28(土) 7:40 回答[未読]

【60551】一つのシートから、複数のシートの作成
質問  nokubo  - 09/2/27(金) 16:12 -

引用なし
パスワード
   早速ですが、ご質問させて頂きます。

A列には10000から始まる部品コードが50000まで入力されております。
部品コードの上2桁をシート名とし、上2桁が一致する部品コードを取得したいと
考えております。

例:10000〜10999までがSheet名『10』
  11000〜11999までがSheet名『11』
  13000〜13999までがSheet名『13』
※桁が飛ぶ場合もあります。
  Sheet名『10』のデータはA2:A1000,10000:10999です。
  A列を走査して、50000以降はデータが入っていないので、
  プログラムを終了する。というようにしたいのです。

IFの条件がA列の値の上2桁でするにはどのようにしたらいいのでしょうか?

IF Sheet1のA2が空白でなければ、新たにA2の上2桁の値をシート名とした、シートを作成する。

Sheet1のA3の上2桁の値がA3の上のセルの値と同じであればA3の値を新たに作成した、シートへ転記する。

上記のような事をしたいとおもっていますが、可能でしょうか?

【60554】Re:一つのシートから、複数のシートの作成
発言  ponpon  - 09/2/27(金) 22:19 -

引用なし
パスワード
   ▼nokubo さん:
>
>A列には10000から始まる部品コードが50000まで入力されております。
>部品コードの上2桁をシート名とし、上2桁が一致する部品コードを取得したいと
>考えております。
>
>例:10000〜10999までがSheet名『10』
>  11000〜11999までがSheet名『11』
>  13000〜13999までがSheet名『13』
>※桁が飛ぶ場合もあります。
>  Sheet名『10』のデータはA2:A1000,10000:10999です。
>  A列を走査して、50000以降はデータが入っていないので、
>  プログラムを終了する。というようにしたいのです。

ならば、Sheet名は、『10』から『49』までですよね?
はじめにシートを作成し、

A列の値の上2桁を取得するには、

Sub test()
  Dim i As Long
  Dim myVal As Long
  
  With Sheets("Sheet1")
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
      If Not IsEmpty(Cells(i, 1).Value) Then
        myVal = Left(Cells(i, 1).Value, 2)
      End If
     ' MsgBox myVal
    Next
  End With
End Sub


でできると思うので、後はSelect Caseで分岐したらいかがでしょう?

>
>IF Sheet1のA2が空白でなければ、新たにA2の上2桁の値をシート名とした、シートを作成する。
>
>Sheet1のA3の上2桁の値がA3の上のセルの値と同じであればA3の値を新たに作成した、シートへ転記する。
>
>上記のような事をしたいとおもっていますが、可能でしょうか?

【60556】Re:一つのシートから、複数のシートの作成
回答  Street  - 09/2/27(金) 22:36 -

引用なし
パスワード
   エラー処理は全くなので参考程度で。
Sub Sample()
  Dim Dic, buf, Keys
  Dim i As Long, j As Long, cnt As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  cnt = Range("a65536").End(xlUp).Row
  Application.ScreenUpdating = False
  For i = 2 To cnt
    buf = WorksheetFunction.RoundUp(Cells(i, 1) / 1000, 0)
    If Not Dic.Exists(buf) Then
      Dic.Add buf, buf
    End If
  Next i
  Keys = Dic.Keys
  For i = 0 To Dic.Count - 1
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Keys(i)
  Next i
  With Worksheets(1)
    For i = 0 To UBound(Keys)
      For j = 2 To .Range("a1:a" & .Range("a65536").End(xlUp).Row).Rows.Count
        If Left(.Cells(j, 1), 2) * 1 = Keys(i) Then
        .Cells(j, 1).Copy Worksheets(i + 2).Range("a" & Worksheets(i + 2).Range("a65536").End(xlUp).Row + 1)
        End If
      Next
    Next
  End With
  Application.ScreenUpdating = True
  Set Dic = Nothing
End Sub

【60557】Re:一つのシートから、複数のシートの作成
発言  kanabun  - 09/2/28(土) 0:51 -

引用なし
パスワード
   ▼nokubo さん:
>早速ですが、ご質問させて頂きます。

遅ればせながら、ご発言させていただきます。
フィルタオプションで A列コード2桁を抽出して、
その2桁コードを条件にして、フィルタオプションで2桁コードのシートへ
抽出転記するサンプルです。
2桁コードの シートは 実行前には 存在しないもの仮定し、新規作成してます。

Sub Try1()
  Dim myTable As Range, r As Range, c As Range
  Dim x As Long, xplus As Long 'xは 表の列数 xPlusは 作業列番号(x + 1)
  Dim rCopy As Range, CopyTo As Range
  Dim ws As Worksheet
  
  '転記元シートの元表 (1行目は見出し行とする)
  With Worksheets("Sheet1")
    Set myTable = .Cells(1).CurrentRegion
    x = myTable.Columns.Count
    xplus = x + 1
    Set rCopy = .Range("AA1")
    rCopy.CurrentRegion.Clear
  End With
  
  'テーブルの右隣りに A列「部品コード」の左2桁を書き出す
  Set r = myTable.Columns(xplus)
  With r
    .Value = Application.Replace(myTable.Columns(1), 3, 10, "")
    '2桁の種類を書き出す [BA列以降]
    .AdvancedFilter xlFilterCopy, , rCopy, Unique:=True
  End With
  With rCopy
    .CurrentRegion.Offset(2).Copy
    .Offset(1, 1).PasteSpecial xlPasteValues, Transpose:=True
    .CurrentRegion.Rows(1).Value = rCopy.Value
  End With
  
  '2桁のコードのシートを作成し、該当するものを一括コピー
  For Each c In rCopy.CurrentRegion.Rows(1).Cells
    Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    ws.Name = CStr(c.Item(2, 1).Value)
    Set CopyTo = ws.Cells(1).Resize(, x)
    CopyTo.Value = myTable.Rows(1).Value
    myTable.Resize(, xplus).AdvancedFilter _
                xlFilterCopy, c.Resize(2), CopyTo
  Next
  r.Clear
  rCopy.CurrentRegion.Clear
End Sub

【60558】Re:一つのシートから、複数のシートの作成
回答  Hirofumi  - 09/2/28(土) 7:40 -

引用なし
パスワード
   A列に昇順整列を掛け、上から見て行って、2桁の値が変わった所でCopy
と言う方法で

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜L列)
  Const clngColumns As Long = 12
  'グループの有る列(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

  '画面更新を停止
  Application.ScreenUpdating = False
  
  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, _
            clngGroup).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    With .Offset(1, clngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, _
          Date:=xlDay, Step:=1, Trend:=False
    End With
    'データをA列で整列
    DataSort .Offset(1).Resize(lngRows, _
        clngColumns + 1), .Offset(, clngGroup)
    '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 Left(vntGroup(lngTop, 1), 2) <> Left(vntGroup(i, 1), 2) Then
      '出力シートを設定
      GetSheets Left(vntGroup(lngTop, 1), 2), cstrTop, _
            rngResult, rngHeader
      'データを転記
      rngList.Offset(lngTop).Resize(lngCount, _
            clngColumns).Copy Destination:=rngResult
      '注目値の位置を記録
      lngTop = i
      'データ行数のカウント初期値に
      lngCount = 1
    Else
      'データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i

  With rngList
    '元データを復帰
    DataSort .Offset(1).Resize(lngRows, _
          clngColumns + 1), .Offset(1, clngColumns)
    '復帰用Key列を削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
   
  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:=lngOrientation, 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 <= 0 Then
      '列見出しを出力
      rngHeader.Copy Destination:=.Offset
      '出力位置を設定
      Set rngResult = .Offset(rngHeader.Rows.Count)
    Else
      '出力位置を設定
      Set rngResult = .Offset(lngRows + 1)
    End If
  End With
  
  Set wksMark = Nothing
      
End Sub

【60569】Re:一つのシートから、複数のシートの作成
お礼  nokubo  - 09/3/2(月) 11:02 -

引用なし
パスワード
   ▼ponpon様、Street様、kanabun様、Hirofumi様

ご返信が遅れ申し訳ないです。
現在、全てのやり方を試しております。
構文を理解しようとヘルプを見ながらがんばっております。
すべて理解し終わりましたら、あらためてお礼を申し上げます。
その上で、解らない箇所をご質問させて頂くかもしれませんが、
お暇でしたら、おつきあいください。

ありがとうございます。

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