Excel VBA質問箱 IV

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

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


2633 / 13645 ツリー ←次へ | 前へ→

【66777】データ抽出(初心者すみません。。。) ヤヨエ 10/10/5(火) 23:22 質問[未読]
【66778】Re:データ抽出(初心者すみません。。。) かみちゃん 10/10/5(火) 23:53 発言[未読]
【66779】Re:データ抽出(初心者すみません。。。) keisuke 10/10/6(水) 1:38 発言[未読]
【66781】Re:データ抽出(初心者すみません。。。) Hirofumi 10/10/6(水) 9:19 回答[未読]
【66782】Re:データ抽出(初心者すみません。。。) Hirofumi 10/10/6(水) 9:21 回答[未読]
【66825】Re:データ抽出(初心者すみません。。。) ヤヨエ 10/10/8(金) 10:48 お礼[未読]

【66777】データ抽出(初心者すみません。。。)
質問  ヤヨエ  - 10/10/5(火) 23:22 -

引用なし
パスワード
   会社で男性社員に小馬鹿にされて2日前からVBAを学び始めました。
色々サイトで調べているのですが、なんせ使われている言葉から
色々分かりません。。。

手っ取り早く答えだけ教えてくれなととどはいえませんが、
ご協力頂戴できないでしょうか。。。(このままでは悔しいし)


Sheet1が年間集計表でA列に処理月が入力されます。B列に品名、C列
価格、D列云々と1行毎にデータをおよそ1000行まで入力されます。

Sheet2から4月、Sheet3に5月・・・と処理月12枚のシートを用意して
Sheet1の年間集計表A列に入力された処理月で各行のデータを各シート
に上からコピーをしたく考えています。

これをすべて関数でやっているのですが、超アナログだと笑われ
ました。。。

確かにIF関数など一つのセルに複数入れ込んでて間違って消したり
したらまた一仕事だったりはするので、今回VBAで書けたらなと
思っています。

どなたかご教示頂けないでしょうか。。。

【66778】Re:データ抽出(初心者すみません。。。)
発言  かみちゃん E-MAIL  - 10/10/5(火) 23:53 -

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

>Sheet1が年間集計表でA列に処理月が入力されます。B列に品名、C列
>価格、D列云々と1行毎にデータをおよそ1000行まで入力されます。
>
>Sheet2から4月、Sheet3に5月・・・と処理月12枚のシートを用意して
>Sheet1の年間集計表A列に入力された処理月で各行のデータを各シート
>に上からコピーをしたく考えています。

Sheet1とSheet2〜Sheet13までの1行目を項目行としているのでしょうか?
その項目行は、各シートとも同じ値ですか?
それであれば、各シートで「フィルタオプションの設定」で抽出すればいいと思います。

「フィルタオプションの設定」は、一般操作ですが、わかりますか?

それがわかるのであれば、まずは、「マクロの記録」で記録してみませんか?

提示されたコードをただ、貼り付けて、実行するより、「マクロの記録」であっても、
自分で記録したコードを修正していくほうがいいと思いませんか?

それとも、サクッと動くコードを提示したほうがいいでしょうか?
いくらでも協力はしますが、そのあたりは、どのようにお考えでしょうか?

【66779】Re:データ抽出(初心者すみません。。。)
発言  keisuke  - 10/10/6(水) 1:38 -

引用なし
パスワード
   色々条件がありますが簡単に、、、
かみちゃんさんもおしゃっている通りだと思いますが、
別の方法で勉強がてらどうでしょうか?


ただし、実際に使用するにはA列は12月と入力されていたり12/26のような場合は、
シートを指定する部分は変更が必要です、

ヘルプ等も利用して命令文を理解してみてください。
他人の何気ない言葉で奮起して勉強使用とする気持ちは大事ですね。


Sub 振り分け()

Dim X As Long, GYO As Long, SHGYO As Long
Dim i As Single
Dim Z As Variant
 
GYO = Worksheets(1).Range("$A1100").End(xlUp).Row 'シート1の最終行を取得
 
 
For X = 2 To GYO           '多分1行目は項目行で2行目からループ

 Z = Worksheets(1).Cells(X, 1).Resize(1, 5).Value '配列に代入A列〜E列まで
 i = Worksheets(1).Range ("A" & X) + 1      'A列は月として数字と仮定
                     'データを写すシートの最終行に1を足す
 SHGYO = Worksheets(i).Range("$A65536").End(xlUp).Row + 1
                        'セルへ配列をいれる
 Worksheets(i).Cells(SHGYO, 1).Resize(1, 5).Value = Z
Next X


End Sub

【66781】Re:データ抽出(初心者すみません。。。)
回答  Hirofumi  - 10/10/6(水) 9:19 -

引用なし
パスワード
   Sheet1には、列見出しが有る物とします
Keyと成るA列の処理月はシリアル値とします
データは、A列〜L列の12列とし、転記するグループは、A列に有るとします
実行時にA列で整列され終了直前に元の行位置に再整列されます

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
    'データをA列で整列
    .Offset(1).Resize(lngRows, clngColumns).Sort _
        Key1:=.Offset(, clngGroup), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '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 Month(vntGroup(lngTop, 1)) <> Month(vntGroup(i, 1)) Then
      '出力シートを設定
      GetSheets Format(vntGroup(lngTop, 1), "m月"), cstrTop, _
          rngResult, rngHeader
      'データを転記
      rngList.Offset(lngTop).Resize(lngCount, clngColumns).Copy _
          Destination:=rngResult
      '注目値の位置を記録
      lngTop = i
      'データ行数のカウント初期値に
      lngCount = 1
    Else
      'データ行数のカウントを更新
      lngCount = lngCount + 1
    End If
  Next i

  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)
  
  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:=.Cells(1, 1)
'      '出力位置を設定
'      Set rngResult = .Offset(1)
'    Else
'      '出力位置を設定
'      Set rngResult = .Offset(lngRows + 1)
'    End If
'  End With
  
  '転記先のシートを全てクリアして転記する場合
  With wksMark
    'データを消去
    .UsedRange.ClearContents
    '列見出しを出力
    rngHeader.Copy Destination:=.Range(strTop)
    '出力位置を設定
    Set rngResult = .Range(strTop).Offset(1)
  End With
  
  Set wksMark = Nothing
      
End Sub

【66782】Re:データ抽出(初心者すみません。。。)
回答  Hirofumi  - 10/10/6(水) 9:21 -

引用なし
パスワード
   「実行時にA列で整列され終了直前に元の行位置に再整列されます」

は間違いで

「実行時にA列で整列されます」

です

【66825】Re:データ抽出(初心者すみません。。。)
お礼  ヤヨエ  - 10/10/8(金) 10:48 -

引用なし
パスワード
     かみちゃんさん、keisukeさん、Hirofumiさん、
  ありがとうございました。
  
  よく噛み砕いてみます。いきなり答えを
  頂戴致しましたが、一切分かりません。。。
  
  一行ずつ調べていってみます。。。

  勝手ですが、可能でしたら再度投稿致しますので、
  どうぞご教示の程宜しくお願い致します。

 

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