Excel VBA質問箱 IV

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

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


6731 / 13646 ツリー ←次へ | 前へ→

【42947】【42833】Re:抽出結果を別シートに保存 ケンイチ 06/9/26(火) 20:57 質問[未読]
【42949】Re:【42833】Re:抽出結果を別シートに保存 Hirofumi 06/9/26(火) 22:13 回答[未読]
【42966】Re:【42833】Re:抽出結果を別シートに保存 ケンイチ 06/9/28(木) 10:16 お礼[未読]
【42968】Re:【42833】Re:抽出結果を別シートに保存 ケンイチ 06/9/28(木) 11:11 質問[未読]
【42990】Re:【42833】Re:抽出結果を別シートに保存 Hirofumi 06/9/28(木) 18:47 回答[未読]
【43000】Re:【42833】Re:抽出結果を別シートに保存 ケンイチ 06/9/28(木) 22:21 質問[未読]
【43043】Re:【42833】Re:抽出結果を別シートに保存 Hirofumi 06/9/30(土) 6:46 回答[未読]
【43473】Re:【42833】Re:抽出結果を別シートに保存 事務員 06/10/16(月) 21:34 質問[未読]
【43502】Re:【42833】Re:抽出結果を別シートに保存 Hirofumi 06/10/17(火) 19:36 回答[未読]

【42947】【42833】Re:抽出結果を別シートに保存
質問  ケンイチ  - 06/9/26(火) 20:57 -

引用なし
パスワード
   Hirofumiさん
 こんばんは、【42833】レッスンを拝見いたしました。
VBAの知識がないため、コードへの理解は難航しています・・・、
もし可能であれば、このコードを利用して、どんな問題を解決できるのか?を教えて
いただければ、幸いです。

【42949】Re:【42833】Re:抽出結果を別シートに保存
回答  Hirofumi  - 06/9/26(火) 22:13 -

引用なし
パスワード
   回答に成らないかも知れませんが?

>  Hirofumiさん
> こんばんは、【42833】レッスンを拝見いたしました。
>VBAの知識がないため、コードへの理解は難航しています・・・、
>もし可能であれば、このコードを利用して、どんな問題を解決できるのか?を教えて
>いただければ、幸いです。

「このコードを利用して、どんな問題を解決できるのか?」と聞かれても、
「はい、こんなです」とは言い難いのですが?

このコードの目的は、Listの中でKeyの有る列で、同一Key毎全てのレコードを指定されたシートに、
若しくは、無い場合シートを作成し転記するコードです
ただ、通常は、Listの列数も固定、Keyの有る列も固定で書くのですが?
(通常、転記するListの列は決まっている筈ですし、転記する条件の有る列も決まっている筈です)
今回は、一般化?と言うか、Listの列数は不定、Keyの有る列もプログラム起動後に指定したい
と言う質問として受け取ったので、List列数は、列見だしの列数をコードで取得していますし、
Key列もInputBoxで取得する様にしています
因って、色々なListで、有る列に有るKey事に仕訳をしたい様な時に使えば善いのかな?

【42966】Re:【42833】Re:抽出結果を別シートに保存
お礼  ケンイチ  - 06/9/28(木) 10:16 -

引用なし
パスワード
   Hirofumiさん
 ご回答いただき、ありがとうございます。
元帳のデータに対して、勘定項目毎に「仕分作業」を行うとき、すごく役立つ機能
だと、実感いたしました。

【42968】Re:【42833】Re:抽出結果を別シートに保存
質問  ケンイチ  - 06/9/28(木) 11:11 -

引用なし
パスワード
   Hirofumiさん
申し訳ありません、質問させていただきます。
よろしくお願いします。
勘定項目を元に仕分けする段階で、年月日をグループ基準にして、
以下の集計を同時に行う場合は、可能でしょうか?

Sub test勘定仕訳_Total()
  'GroupByはB列とする
  '合計はE列とする
  Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5), _
    Replace:=True, PageBreaks:=False, SummaryBelowData:=True
  '実行ご、カーソルはA1にセットする
  Range("A1").Select
End Sub

【42990】Re:【42833】Re:抽出結果を別シートに保存
回答  Hirofumi  - 06/9/28(木) 18:47 -

引用なし
パスワード
   ▼ケンイチ さん:
>Hirofumiさん
>申し訳ありません、質問させていただきます。
>よろしくお願いします。
>勘定項目を元に仕分けする段階で、年月日をグループ基準にして、
>以下の集計を同時に行う場合は、可能でしょうか?
>
>Sub test勘定仕訳_Total()
>  'GroupByはB列とする
>  '合計はE列とする
>  Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(5), _
>    Replace:=True, PageBreaks:=False, SummaryBelowData:=True
>  '実行ご、カーソルはA1にセットする
>  Range("A1").Select
>End Sub

実際のイメージが湧かないので、
具体的に、元と成るシートがどう言う物で、どの様な集計をして、
結果をどう出力かをシートのレイアウトを含めて書いていただけると
有りがたいのですが?

【43000】Re:【42833】Re:抽出結果を別シートに保存
質問  ケンイチ  - 06/9/28(木) 22:21 -

引用なし
パスワード
   Hirofumiさん
 説明不足で、申し訳ありません。

元帳DBから、
仕分けされたデータ(シート名:AA)中間計算結果として:
a1    a2    a3    a4    a5    a6    a7   a8
1    B1    C1    D1    5    F1    G1  AA
2    B2    C2    D2    6    F2    G2  AA
3    B3    C3    D3    7    F3    G3  AA
4    B4    C4    D4    8    F4    G4  AA
5    B5    C5    D5    9    F5    G5  AA
6    B6    C6    D6    10    F6    G6  AA
7    B7    C7    D7    11    F7    G7  AA
8    B8    C8    D8    12    F8    G8  AA
9    B9    C9    D9    13    F9    G9  AA
10    B10    C10    D10    14    F10    G10 AA
11    B11    C11    D11    15    F11    G11 AA
12    B12    C12    D12    16    F12    G12 AA
13    B13    C13    D13    17    F13    G13 AA
14    B14    C14    D14    18    F14    G14 AA

上記仕分けされたデータ(シート名:AA)をGroupBy集計した最終結果:
a1    a2    a3    a4    a5    a6    a7   a8
1    B1    C1    D1    5    F1    G1  AA
2    B1    C2    D2    6    F2    G2  AA
3    B1    C3    D3    7    F3    G3  AA
4    B1    C4    D4    8    F4    G4  AA
    B1 合計            26        
5    B5    C5    D5    9    F5    G5  AA
6    B5    C6    D6    10    F6    G6  AA
7    B5    C7    D7    11    F7    G7  AA
8    B5    C8    D8    12    F8    G8  AA
9    B5    C9    D9    13    F9    G9  AA
10    B5    C10    D10    14    F10    G10 AA
11    B5    C11    D11    15    F11    G11 AA
    B5 合計            84        
12    B12    C12    D12    16    F12    G12 AA
13    B12    C13    D13    17    F13    G13 AA
14    B12    C14    D14    18    F14    G14 AA
    B12 合計        51        
    総計            161

【43043】Re:【42833】Re:抽出結果を別シートに保存
回答  Hirofumi  - 06/9/30(土) 6:46 -

引用なし
パスワード
   レイアウト有り難う御座います
今回の場合、データ列数と、振り分けに使用するKeyの列は決まっている様なので固定して居ます
また、データ元が「元帳DB」で入力フォームでは無さそうなので、
作られる仕分シートは一過性の物として、マクロが実行される毎ににクリアされます
元帳DBには、列見出しが有る物とします
元帳DBは、実行時に抽出Keyで整列され終了直前に元の行位置に再整列されます
勘定項目、日付、集計列の位置は、rngListを基準とした列Offsetとします
例えば、A1(列見出し「a1」)を基準とすると、A列は0、B列は1、C列は2

Option Explicit
Option Compare Text

Public Sub Sample2()

  '元帳DBのデータ列数(A列〜H列)
  Const clngColumns As Long = 8
  '元帳DBの勘定項目列(基準セル位置「A列」からの列Offset「H列」)
  Const clngGroup As Long = 7
  '元帳DBの日付列(基準セル位置「A列」からの列Offset「B列」)
  Const clngDate As Long = 1
  '元帳DBの集計列(基準セル位置「A列」からの列Offset「E列」)
  Const clngSum As Long = 4
  '結果出力シートの先頭位置
  Const cstrTop As String = "A1"
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngRow 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 vntColumnWidth As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(列見出し「a1」のセル位置)
  Set rngList = Worksheets("元帳DB").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
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データを抽出昇順の日付昇順で整列
    DataSort .Offset(1).Resize(lngRows, _
          clngColumns + 1), .Offset(, clngDate)
    DataSort .Offset(1).Resize(lngRows, _
          clngColumns + 1), .Offset(, clngGroup)
    '抽出Keyデータを配列に取得
    vntGroup = .Offset(1, clngGroup) _
              .Resize(lngRows + 1).Value
    '列見出し範囲を取得
    Set rngHeader = .Resize(, clngColumns)
    '列幅を取得
    ReDim vntColumnWidth(clngColumns - 1)
    For i = 0 To clngColumns - 1
      vntColumnWidth(i) _
          = .Offset(, i).EntireColumn.ColumnWidth
    Next i
  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, vntColumnWidth, clngDate
      With rngResult
      'データを転記
        rngList.Offset(lngTop).Resize(lngCount, _
            clngColumns).Copy Destination:=.Offset(1)
        '日付毎に集計
        .CurrentRegion.Subtotal _
          GroupBy:=clngDate + 1, Function:=xlSum, _
          TotalList:=clngSum + 1, Replace:=True, _
          PageBreaks:=False, SummaryBelowData:=True
      End With
      '注目値の位置を記録
      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 GetSheets(strName As String, _
            strTop As String, _
            rngResult As Range, _
            rngHeader As Range, _
            vntWidth As Variant, _
            lngDate As Long)
  
  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)
    On Error Resume Next
    wksMark.Name = strName
    On Error GoTo 0
  End If
  
  'シートのstrTopを出力基準セル位置とする
  Set rngResult = wksMark.Range(strTop)
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, _
            lngDate).End(xlUp).Row - .Row
    'シートにデータが無い場合
    If lngRows <= 0 Then
      '列幅を設定
      For i = 0 To UBound(vntWidth, 1)
        .Offset(, i).EntireColumn.ColumnWidth = vntWidth(i)
      Next i
      '列見出しを出力
      rngHeader.Copy Destination:=.Offset
    Else
      'Subtotalを解除
      .CurrentRegion.RemoveSubtotal
      'シートのデータを消去
      .Offset(1).Resize(lngRows, _
          UBound(vntWidth, 1) + 1).ClearContents
    End If
  End With
  
  Set wksMark = Nothing
      
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

【43473】Re:【42833】Re:抽出結果を別シートに保存
質問  事務員  - 06/10/16(月) 21:34 -

引用なし
パスワード
   Hirofumiさん
 返事がなりました、ごめんなさい。
 「仕分け」機能を使って、何の問題もなく、正確にできています。
ただ一点だけ、仕分けする前に並べ替えしておかないと、集計の合計が
バラバラとなります。
 仕分けする前に、まず並べ替えて、そして仕分けにするというように実施したい
場合は、どのようにかけば可能になりますか?

【43502】Re:【42833】Re:抽出結果を別シートに保存
回答  Hirofumi  - 06/10/17(火) 19:36 -

引用なし
パスワード
   > 「仕分け」機能を使って、何の問題もなく、正確にできています。
>ただ一点だけ、仕分けする前に並べ替えしておかないと、集計の合計が
>バラバラとなります。
> 仕分けする前に、まず並べ替えて、そして仕分けにするというように実施したい
>場合は、どのようにかけば可能になりますか?

何を、如何並べ替え(整列し)なければ成らないのですか?
必要な整列はコードの中で行っているはずです?
また、バラバラに成るとは、どの様な現象ですか?

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