Excel VBA質問箱 IV

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

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


55137 / 76732 ←次へ | 前へ→

【26374】Re:効率的なコードにするには…。
回答  Hirofumi  - 05/7/3(日) 17:59 -

引用なし
パスワード
   考え過ぎで、複雑にし過ぎました
もっとコードが簡単に速くなります

Option Explicit

Public Sub Cross2()

  Dim i As Long
  Dim lngRow As Long
  Dim lngColumn As Long
  Dim vntOffice As Variant
  Dim wkbData As Workbook
  Dim wksData As Worksheet
  Dim vntData As Variant
  Dim wksResult As Worksheet
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim strSheet As String
  Dim lngWrite As Long
  Dim vntItems As Variant
  Dim strProm As String
  
  Dim vntFileName As Variant
  
  '出力する列見出しを設定(営業部門名)
  vntOffice = Array("", "京都", "大阪", "神戸", "合計")
  
  'シート名を取得
  strSheet = InputBox("処理するシートを「2005.6」の形で入力して下さい ", _
                  "シート名入力", Format(Date, "yyyy.m"))
  If strSheet = "" Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  'シートの存在確認
  If SheetsCheck(strSheet, wksResult, ActiveWorkbook) Then
    Set rngResult = wksResult.Cells(2, "B")
  Else
    strProm = "出力先のWorkSheet「" & strSheet & "」が有りません"
    GoTo Wayout
  End If
  
'  Application.ScreenUpdating = False
  
  'ファイルのOpen
  Set wkbData = Workbooks.Open("C:\Documents and Settings\質問\db.xls")
  'シートの存在確認、データの取得
  If SheetsCheck(strSheet, wksData, wkbData) Then
    With wksData.Cells(1, "A")
      'データ行数の取得
      lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
      If lngRow <= 0 Then
        strProm = "データ元のデータが有りません"
        wkbData.Close SaveChanges:=False
        GoTo Wayout
      End If
      With .Offset(1).Resize(lngRow, 4)
        .Sort Key1:=.Item(1, 1), Order1:=xlAscending, _
            Key2:=.Item(1, 3), Order2:=xlAscending, _
            Key3:=.Item(1, 2), Order3:=xlAscending, _
            Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, SortMethod:=xlStroke
        'データを配列に取得
        vntData = .Value
      End With
      wkbData.Close SaveChanges:=False
    End With
  Else
    strProm = "データ元のWorkSheet「" & strSheet & "」が有りません"
    wkbData.Close SaveChanges:=False
    GoTo Wayout
  End If
    
  '集計の初期値設定、配列の確保
  lngRow = 0
  ReDim vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
  vntOffice(0) = vntData(1, 1)
  vntItems(lngRow) = vntData(1, 3)
  
  '集計
  For i = 1 To UBound(vntData, 1)
    lngColumn = ColumnSearch(vntData(i, 2), vntOffice)
    If lngColumn = -1 Then
      strProm = "未登録の営業部門が有りますのでマクロを終了します"
      GoTo Wayout
    Else
      '得意先が替わったら
      If vntOffice(0) <> vntData(i, 1) Then
        '結果を出力
        DataWrite rngResult, lngWrite, vntResult, vntOffice, vntItems
        '集計の初期値設定、配列の確保
        lngRow = 0
        ReDim vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
        vntOffice(0) = vntData(i, 1)
        vntItems(lngRow) = vntData(i, 3)
      Else
        '商品を探して、集計
        If vntItems(lngRow) <> vntData(i, 3) Then
          lngRow = lngRow + 1
          ReDim Preserve vntResult(UBound(vntOffice) - 1, lngRow), vntItems(lngRow)
          vntItems(lngRow) = vntData(i, 3)
        End If
      End If
      vntResult(lngColumn, lngRow) _
          = vntResult(lngColumn, lngRow) + vntData(i, 4)
    End If
  Next i
  DataWrite rngResult, lngWrite, vntResult, vntOffice, vntItems
  
  strProm = "処理が完了しました"
  
Wayout:
  
'  Application.ScreenUpdating = True
  
  Set wkbData = Nothing
  Set wksData = Nothing
  Set wksResult = Nothing
  Set rngResult = Nothing
  
  Beep
  MsgBox strProm
  
End Sub

Private Function SheetsCheck(strMark As String, _
              wksMark As Worksheet, _
              wkbBook As Workbook) As Boolean

  With wkbBook
    For Each wksMark In .Worksheets
      If StrComp(wksMark.Name, strMark) = 0 Then
        SheetsCheck = True
        Exit Function
      End If
    Next wksMark
  End With
  
End Function

Private Function ColumnSearch(vntKey As Variant, _
                vntList As Variant) As Long

  Dim i As Long
  
  ColumnSearch = -1
  For i = 1 To UBound(vntList)
    If vntList(i) = vntKey Then
      ColumnSearch = i - 1
      Exit Function
    End If
  Next i
      
End Function

Private Sub DataWrite(rngOutput As Range, _
            lngWrite As Long, _
            vntResult As Variant, _
            vntOffice As Variant, _
            vntItems As Variant)
  Dim i As Long
  Dim j As Long
  Dim lngRow As Long
  Dim lngColumn As Long
  
  lngRow = UBound(vntResult, 2) + 1
  lngColumn = UBound(vntOffice) - 1
  ReDim Preserve vntResult(lngColumn, lngRow)
  For i = 0 To lngRow - 1
    For j = 0 To lngColumn - 1
      vntResult(lngColumn, i) = vntResult(lngColumn, i) + vntResult(j, i)
      vntResult(j, lngRow) = vntResult(j, lngRow) + vntResult(j, i)
    Next j
  Next i
  
  lngColumn = UBound(vntItems) + 1
  ReDim Preserve vntItems(lngColumn)
  vntItems(lngColumn) = "合計"
  
  With rngOutput.Offset(lngWrite)
    .Offset(, -1).Resize(, UBound(vntOffice) + 1).Value = vntOffice
    .Offset(1, -1).Resize(UBound(vntResult, 2) + 1).Value _
        = Application.Transpose(vntItems)
    .Offset(1).Resize(UBound(vntResult, 2) + 1, _
        UBound(vntOffice)).Value _
            = Application.Transpose(vntResult)
  End With
  lngWrite = lngWrite + UBound(vntItems, 1) + 1 + 2

End Sub

0 hits

【26368】効率的なコードにするには…。 あさみ 05/7/2(土) 23:54 質問
【26370】Re:効率的なコードにするには…。 かみちゃん 05/7/3(日) 11:30 発言
【26371】Re:効率的なコードにするには…。 あさみ 05/7/3(日) 12:14 お礼
【26373】Re:効率的なコードにするには…。 かみちゃん 05/7/3(日) 14:36 発言
【26375】Re:効率的なコードにするには…。 あさみ 05/7/3(日) 20:32 お礼
【26380】Re:効率的なコードにするには…。 あさみ 05/7/4(月) 1:00 質問
【26387】Re:効率的なコードにするには…。 かみちゃん 05/7/4(月) 12:52 発言
【26416】Re:効率的なコードにするには…。 あさみ 05/7/5(火) 2:05 発言
【26417】Re:効率的なコードにするには…。 かみちゃん 05/7/5(火) 6:39 発言
【26465】Re:効率的なコードにするには…。 あさみ 05/7/6(水) 7:16 発言
【26487】Re:効率的なコードにするには…。 かみちゃん 05/7/6(水) 22:53 発言
【26372】Re:効率的なコードにするには…。 Hirofumi 05/7/3(日) 14:01 回答
【26374】Re:効率的なコードにするには…。 Hirofumi 05/7/3(日) 17:59 回答
【26376】Re:効率的なコードにするには…。 あさみ 05/7/3(日) 20:34 お礼
【26377】Re:効率的なコードにするには…。 Hirofumi 05/7/3(日) 20:54 回答
【26379】Re:効率的なコードにするには…。 あさみ 05/7/3(日) 22:19 お礼

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