Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

21567 / 76732

←次へ　｜　前へ→


	【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

0 hits

▼

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