Excel VBA質問箱 IV

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

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


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

【43785】複雑な(?)転記 更夜 06/10/25(水) 17:33 質問[未読]
【43786】Re:複雑な(?)転記 ゆと 06/10/25(水) 18:09 発言[未読]
【43788】Re:複雑な(?)転記 ゆと 06/10/25(水) 19:05 発言[未読]
【43818】Re:複雑な(?)転記 更夜 06/10/26(木) 11:48 発言[未読]
【43848】Re:複雑な(?)転記 Hirofumi 06/10/26(木) 20:22 回答[未読]
【43945】Re:複雑な(?)転記 更夜 06/10/30(月) 15:20 お礼[未読]

【43785】複雑な(?)転記
質問  更夜  - 06/10/25(水) 17:33 -

引用なし
パスワード
   初めまして、VBA超初心者の更夜という者です。

業務で使っている集計表が完全手打ちの上、操作するデータが膨大なもので
VBAを勉強しながら使いやすいものに変えていこうとしているのですが、序盤から
躓いてしまったのでどなたかご教唆頂けませんでしょうか・・・

問題の集計表は、CSVで出力されたデータを取り込み、表に整理して更にグラフにするまでを手作業で行っています。

自分以外の人にも利用できるようにSheet1にコマンドボタンを設置し、CSVの読み込みから表への転記までをボタンで行いたいと思っています。

1.Sheet1のボタンでCSVファイルをSheet2へ読み込む。
2.Sheet2へ読み込んだデータをSheet3の予め作成してある表へ転記。(複数列を任意の順番で表へコピー)
 読み込むCSVファイルは行数が未定。Sheet3の表は行数が決まっていて(印刷レイアウトの為)、その行数を超えたら右側に作ってある同じ表へ転記したい。

1まではできているのですが、「行数が未定の行を転記」し、更にSheet3の 「決まっている行数以上のデータは隣の別表へ転記」というのがさっぱりできません。

ヒントだけでも結構ですので、どなたか教えてください。
説明がわかりづらいかもしれませんが、よろしくお願いします。

【43786】Re:複雑な(?)転記
発言  ゆと  - 06/10/25(水) 18:09 -

引用なし
パスワード
   こんにちは。
回答でなくてすみません。

表のレイアウトが出ていないので、何とも言えないのです。
データ数によっては、右側の表に転記しても再度超過する場合
はどうされるのでしょうか?
など、読み取れない部分が多いのですが…。

2の部分はもう少し細かいステップにわけられると思います。
そこでわからない点を明確にされた方が良いかと。

【43788】Re:複雑な(?)転記
発言  ゆと  - 06/10/25(水) 19:05 -

引用なし
パスワード
   Sheet2に以下の様にデータを入れて、Sheet3に転記するサンプルを作ってみました。
定数を適当にいじってみてください。

   A   B
1 name Value
2  a  300
3  b  100
4  c  50
5  d  175
6  e  25
7  f  210


Sub Sample1()
 Dim EndRow&, TRange As Range
 Dim T_Sheet As Worksheet, P_Sheet As Worksheet
 Const T1Col$ = "A", T2Col$ = "B"
 Const P1Col$ = "A", P2Col$ = "D"
 Const StaRow& = 2, PasRow& = 2
 Const B_Line& = 5
 Set T_Sheet = Sheets("Sheet2")
 Set P_Sheet = Sheets("Sheet3")
  
 EndRow& = T_Sheet.Cells(65536, T1Col$).End(xlUp).Row
  
 With T_Sheet
  If EndRow& > B_Line& Then
   Set TRange = .Range(.Cells(B_Line& + 1, T1Col$), _
               .Cells(EndRow&, T2Col$))
   TRange.Copy Destination:=P_Sheet.Cells(PasRow&, P2Col$)
   Set TRange = .Range(.Cells(StaRow&, T1Col$), .Cells(B_Line&, T2Col$))
  Else
   Set TRange = .Range(.Cells(StaRow&, T1Col$), .Cells(EndRow&, T2Col$))
  End If
 End With
 TRange.Copy Destination:=P_Sheet.Cells(PasRow&, P1Col$)
      
 Set T_Sheet = Nothing
 Set P_Sheet = Nothing
 Set TRange = Nothing
End Sub

【43818】Re:複雑な(?)転記
発言  更夜  - 06/10/26(木) 11:48 -

引用なし
パスワード
   ゆたさん>
レスありがとうございます。
説明が足りず申し訳ないです・・・

↓このような形のSheet2のデータを
   A  B  C  D  E
1 名前 住所 電話 年齢 ID 
2  :  :  :  :  : 
3  :  :  :  :  : 
4  :  :  :  :  :  
5  :  :  :  :  :
6  :  :  :  :  :
7  :  :  :  :  :


  A  B  C  
1  ID 名前 電話
2  :  :  : 
3  :  :  : 
4  :  :  : 
5  :  :  : 
6  :  :  : 
7  :  :  : 

という感じで抜き出し転記したいと思っています。
行数の制限なのですが、確かにゆたさんの仰るとおり、右の表を越えてしまった場合の対応が難しいですね・・・
良案が浮かばないので行数の制限は付けない方法で作成したいと思います。

Upして頂いたコードを参考にがんばってみます。
ありがとうございました^^

【43848】Re:複雑な(?)転記
回答  Hirofumi  - 06/10/26(木) 20:22 -

引用なし
パスワード
   こんなので、CSVから直接Sheet3の表に読み込むと思います
一応、コード中の下記の部分の設定を替えて試して見て下さい

  '出力する表の行数
  Const clngListCount As Long = 20
  '表の列ピッチを設定(出力する表が何列置きに有るのかを設定)
  Const clngColPitch As Long = 4
  '表の行ピッチを設定(出力する表が何行置きに有るのかを設定)
  Const clngRowPitch As Long = 22
  '表が横方向に何枚並ぶのかを設定(設定例は横に5枚の表が並ぶ)
  Const clngMaxSet As Long = 5
  
  '出力するCsvの列を出力する順に設定
  '例えば、Csvの列が5列の場合、先頭列は0番、最終列は4番と成る
  '例では、ID=4、名前=0、電話=2と成る
  vntPos = Array(4, 0, 2)
  
  '出力先頭セル位置を設定(基準セル位置)
  Set rngResult = Worksheets("Sheet3").Cells(2, "A")

この設定例では、データ行が20行の表が、Sheet3のA2をデータの先頭として有る物としています
また、データがこの表からはみ出した場合、右側の表に出力していきます、此れが5枚を越した場合
最初の表の下2行を空けて次の表が書かれて行きます
詰まり、Z型に出力されます

下記もコードを標準モジュールに記述して下さい

Option Explicit

Public Sub DataRead()

  '出力する表の行数
  Const clngListCount As Long = 20
  '表の列ピッチを設定(出力する表が何列置きに有るのかを設定)
  Const clngColPitch As Long = 4
  '表の行ピッチを設定(出力する表が何行置きに有るのかを設定)
  Const clngRowPitch As Long = 22
  '表が横方向に何枚並ぶのかを設定(設定例は横に5枚の表が並ぶ)
  Const clngMaxSet As Long = 5
  
  Dim i As Long
  Dim lngCount As Long
  Dim dfn As Integer
  Dim vntFileName As Variant
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim lngRow As Long
  Dim rngResult As Range
  Dim lngRowOffset As Long
  Dim lngColOffset As Long
  Dim vntPos As Variant
  Dim vntResult As Variant
  Dim strProm As String

  '出力するCsvの列を出力する順に設定
  '例えば、Csvの列が5列の場合、先頭列は0番、最終列は4番と成る
  '例では、ID=4、名前=0、電話=2と成る
  vntPos = Array(4, 0, 2)
  
  '出力先頭セル位置を設定(基準セル位置)
  Set rngResult = Worksheets("Sheet3").Cells(2, "A")

  '読み込むファイルを取得
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '画面更新を停止
  Application.ScreenUpdating = False

  '出力行初期値(基準セル位置からの行Offset)
  lngRow = 0

  'データの読み込み
  'ファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, ",", , , blnMulti)
    'フィールド内で改行が有る場合
    If Not blnMulti Then
      '出力する配列を確保
      ReDim vntResult(0 To UBound(vntPos))
      'Csvのフィールド配列を出力配列に転記
      On Error Resume Next
      For i = 0 To UBound(vntPos)
        vntResult(i) = vntField(vntPos(i))
      Next i
      On Error GoTo 0
      '出力行位置を計算
      lngRow = lngCount Mod clngListCount
      '何処の表に出力するかを計算
      lngColOffset = ((lngCount \ clngListCount) _
                Mod clngMaxSet) * clngColPitch
      lngRowOffset = ((lngCount \ clngListCount) _
                \ clngMaxSet) * clngRowPitch
      '出力する表を選択
      With rngResult.Offset(lngRowOffset, lngColOffset)
        'データを出力
        .Offset(lngRow).Resize(, _
            UBound(vntResult) + 1).Value = vntResult
      End With
      '処理行数をインクリメント
      lngCount = lngCount + 1
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbLf
    End If
  Loop

  Close #dfn

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

Wayout:

  Set rngResult = Nothing

  '画面更新を再開
  Application.ScreenUpdating = True

  MsgBox strProm, vbInformation

End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

  Dim i As Long
  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim vntField As Variant
  Dim lngLength As Long

  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart)
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart

  SplitCsv = vntData()

End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String

  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If

  GetReadFile = True

End Function

【43945】Re:複雑な(?)転記
お礼  更夜  - 06/10/30(月) 15:20 -

引用なし
パスワード
   Hirofumiさん>
詳細な解説&ソースありがとうございます^^

記載して頂いたコードを参考に試行錯誤してみます。
まったくの初心者なので理解するまでに時間がかかるかと思いますが、何から何まで頼るのも間違っていると思うので、がんばって理解したいと思います。
またわからない事がありましたら質問させて頂きたいと思います。

中途半端な質問に回答頂き、ありがとうございました。

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