Excel VBA質問箱 IV

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

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


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

【41958】教えてください 超初心者 06/8/27(日) 1:26 質問[未読]
【41959】Re:教えてください Kein 06/8/27(日) 2:16 回答[未読]
【41963】Re:教えてください T 06/8/27(日) 10:09 質問[未読]
【41965】Re:教えてください かみちゃん 06/8/27(日) 10:36 発言[未読]
【41968】Re:教えてください T 06/8/27(日) 11:30 お礼[未読]
【41967】Re:教えてください Hirofumi 06/8/27(日) 11:18 回答[未読]

【41958】教えてください
質問  超初心者  - 06/8/27(日) 1:26 -

引用なし
パスワード
   マクロを初めて3日目の超初心者です。

このようなメインシートがあります。

  A     B    C     D     E
1 名前   体重   血圧高   血圧低   体脂肪率
2 宮田   66   131   80    19
3 山中   60   118   71    17      
4 松本   73   122   75    21 
5 西野   60   119   74    15
6 鈴木   62   122   68    13
 
他には

   A      B    C   D ・・・ M
1        1月   2月  3月    12月 
2 体重      
3 血圧高
4 血圧低
5 体脂肪率

という、人数分のシートがあります。

メインシートに数値を入力して、ボタンを押すと、各人ごとのシートにその数値が入るようにして(まず各人シートそれぞれの1月の列に)、その後、メインシートの数値入力セルをクリアーした後、また新たに数値を入力してボタンを押すと、各人シートの2月の列にその数値が・・・というマクロを組みたいのですが、それが出来ずに悪戦苦闘しています。皆さんの知恵を拝借したく投稿します。


  

【41959】Re:教えてください
回答  Kein  - 06/8/27(日) 2:16 -

引用なし
パスワード
   そのようにすると「必ず1月のデータから入力していく必要がある」ので
ちょっと不便ではないかと思われます。マクロを起動したときに、まず
InputBox を出して月の数値(1〜12)を入力し、その月の列にデータを
入力していくようにしたら良いでしょう。
既にメインシートと各人のシートの表組みが出来ているとして、
各人のシート名は各人の名前であることを前提に、メインシートの
シートモジュールに以下のようなイベントマクロを入れて下さい。
最後の体脂肪率を入力したとき、自動的にその行の
名前, 体重, 血圧高, 血圧低, 体脂肪率 が入力されているかチェックし、
名前に一致するシートの指定した月の列にデータを転記します。

Private Sub Worksheet_Change(byVal Target As Range)
  Dim MyR As Range
  Dim Wf As WorksheetFunction
  Dim Mnum As Integer
  Dim Snm As String
  Dim MyV As Variant, Col As Variant

  Set MyR = Range("A2", Range("A65536").End(xlUp)).Offset(, 4)
  Set Wf = Application.WorksheetFunction
  If Intersect(Target, MyR) Is Nothing Then GoTo ELine
  With Target
   If .Count > 1 Then GoTo ELine
   If IsEmpty(.Value) Then GoTo ELine
   If Wf.Count(.Offset(, -3).Resize(, 4)) < 4 Then GoTo ELine
   Snm = .Offset(, -4).Value
   If Snm = "" Then GoTo ELine
   MyV = Wf.Transpose(.Offset(, -3).Resize(, 4).Value)
  End With
  Do
   Mnum = Application _
   .InputBox("入力する月を 1〜12 の数値で入力して下さい", Type:=1)
   If Mnum = 0 Then GoTo ELine
  Loop While Mnum < 0 Or Mnum > 12
  On Error GoTo ELine
  With Worksheets(Snm)
   Col = Application.Match(Mnum & "月", .Rows(1), 0)
   If IsError(Col) Then GoTo ELine
   With .Cells(2, Col).Resize(4)
     .ClearContents
     .Value = MyV
   End With
  End With
ELine:
  Set MyR = Nothing: set Wf = Nothing
End Sub

【41963】Re:教えてください
質問  T  - 06/8/27(日) 10:09 -

引用なし
パスワード
   ▼Kein さん:

興味を持って見させていただいていました。
非常に便利なプログラムで、将来活用したく
シートの準備をして進めましたが・・・・・・

Inputboxの表示までは出るのですが、その後Onをしましても、
それぞれの人名シートにデータが転記できませんが、
何か当方にミスがあると思いますが、何か思い当たる
事項がありましたら、教えてください。

【41965】Re:教えてください
発言  かみちゃん  - 06/8/27(日) 10:36 -

引用なし
パスワード
   こんにちは。かみちゃん です。

横から失礼します。

>Inputboxの表示までは出るのですが、その後Onをしましても、
>それぞれの人名シートにデータが転記できませんが、
>何か当方にミスがあると思いますが、何か思い当たる
>事項がありましたら、教えてください。

「名前」を入力して、「体重」〜「体脂肪率」まですべて入力しましたか?
すべて入力したら、InputBoxの表示が出ます。
そのあと、エラーもなく転記が終了するのでしょうか?
エラーが出るのなら、エラーメッセージと、そのエラーになっているコードを教えてください。
エラーが出ないならば、
  On Error GoTo ELine
のコードを
'  On Error GoTo ELine
とコメント文にして実行してみてください。
そうすると、エラー「インデックスが有効範囲にありません」となれば、
「名前」を入力したシートが用意されていないと思われます。
(全角半角、スペースの有無をよく確認してください。)

また、
   If IsError(Col) Then GoTo ELine
のコードを
'   If IsError(Col) Then GoTo ELine
とコメント文にして実行して、エラー
「型が一致しません」となれば、
個人別の各シートの1行目に、「1月、2月、3月・・」というように「○月」と設定
されていないことと思います。

なお、私の手元では、動作確認できています。(WinXP Pro、Excel2002SP3)

【41967】Re:教えてください
回答  Hirofumi  - 06/8/27(日) 11:18 -

引用なし
パスワード
   Keinさんと同じ様な物かも?
Worksheetのイヴェントでは無く、1月分一編に転記します

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜E列)
  Const clngColumns As Long = 5
  '結果出力の先頭位置
  Const cstrTop As String = "A1"
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim vntMonth As Variant
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(「名前」列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  '月の入力
  strProm = "転記する月を入力して下さい"
  Do
  'ディフォルトとして表示する月を設定(前月を表示、前月以外なら
  '「Month(Date) - 1」を調整する事
    vntMonth = Month(DateSerial(Year(Date), Month(Date) - 1, 1))
    '転記する月を指定
    vntMonth = Application.InputBox(strProm, "月の入力", vntMonth, , , , , 1)
    If VarType(vntMonth) = vbBoolean Then
      strProm = "マクロがキャンセルされました"
      GoTo Wayout
    Else
      '"1〜12の数値以外の場合
      If vntMonth < 1 Or 12 < vntMonth Then
        Beep
        strProm = "1〜12の数値で入力して下さい"
      Else
        Exit Do
      End If
    End If
  Loop
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, clngColumns).Value
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '出力用配列を確保
  ReDim vntResult(1 To 4, 1 To 1)
  '仮に結果と元表を同じにして置く
  Set rngResult = rngList
  'データの先頭〜最終まで繰り返し
  For i = 1 To lngRows
    'データを結果配列に転記
    For j = 2 To clngColumns
      vntResult(j - 1, 1) = vntData(i, j)
    Next j
    '出力シートを設定
    GetSheets CStr(vntData(i, 1)), cstrTop, rngResult
    'データを転記
    rngResult.Offset(1, vntMonth).Resize(clngColumns - 1).Value = vntResult
  Next i
  
  'メインシートのクリア
  rngList.Offset(1, 1).Resize(lngRows, clngColumns - 1).ClearContents
    
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub GetSheets(strName As String, strTop As String, rngResult 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
    With wksMark.Range(strTop)
      '列見出しを出力
      .Offset(, 1).Resize(, 12).Value _
          = Array("1月", "2月", "3月", "4月", "5月", "6月", _
              "7月", "8月", "9月", "10月", "11月", "12月")
      '行見出しを設定
      For i = 1 To 4
        .Offset(i).Value _
            = Choose(i, "体重", "血圧高", "血圧低", "体脂肪率")
      Next i
    End With
  End If
  
  '出力位置を設定
  Set rngResult = wksMark.Range(strTop)
  
  Set wksMark = Nothing
      
End Sub

【41968】Re:教えてください
お礼  T  - 06/8/27(日) 11:30 -

引用なし
パスワード
   ▼かみちゃん さん:

ご指摘していただき
ありがとうございます。

>「名前」を入力して、「体重」〜「体脂肪率」まですべて入力しましたか?
>すべて入力したら、InputBoxの表示が出ます。
>そのあと、エラーもなく転記が終了するのでしょうか?
>エラーが出るのなら、エラーメッセージと、そのエラーになっているコードを教えてください。
>エラーが出ないならば、
>  On Error GoTo ELine
>のコードを
>'  On Error GoTo ELine
>とコメント文にして実行してみてください。
>そうすると、エラー「インデックスが有効範囲にありません」となれば、
>「名前」を入力したシートが用意されていないと思われます。
>(全角半角、スペースの有無をよく確認してください。)

これは問題ありませんでした。

>また、
>   If IsError(Col) Then GoTo ELine
>のコードを
>'   If IsError(Col) Then GoTo ELine
>とコメント文にして実行して、エラー
>「型が一致しません」となれば、
>個人別の各シートの1行目に、「1月、2月、3月・・」というように「○月」と設定
>されていないことと思います。

これでした、非常に微妙で、何べんも入力しなおしたり、コピーで
貼り付けたりし直し、やっと全てが正常に動作しました。
文字の一致には細心の注意が必要であることが分かりました。
ありがとうございました。

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