Excel VBA質問箱 IV

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

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


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

【72452】転記したい うさこ 12/8/13(月) 12:01 質問[未読]
【72454】Re:転記したい UO3 12/8/13(月) 14:08 発言[未読]
【72455】Re:転記したい うさこ 12/8/13(月) 14:13 質問[未読]
【72456】Re:転記したい UO3 12/8/13(月) 14:27 発言[未読]
【72457】Re:転記したい UO3 12/8/13(月) 14:29 発言[未読]
【72458】Re:転記したい うさこ 12/8/13(月) 14:57 質問[未読]
【72461】Re:転記したい うさこ 12/8/13(月) 16:36 質問[未読]
【72462】Re:転記したい Yuki 12/8/13(月) 16:51 発言[未読]
【72465】Re:転記したい UO3 12/8/13(月) 17:19 発言[未読]
【72467】Re:転記したい UO3 12/8/13(月) 17:36 発言[未読]
【72468】Re:転記したい kanabun 12/8/13(月) 17:50 発言[未読]
【72469】Re:転記したい うさこ 12/8/13(月) 18:31 お礼[未読]

【72452】転記したい
質問  うさこ  - 12/8/13(月) 12:01 -

引用なし
パスワード
   初めて投稿します。初心者ですみません。
たとえば、こんなシートになっています。

日付 型番 あ い う え お か き く け こ ←項目名
7/1  A  1 3 8 7 6 5 4 6 8  4 ←データ

9/30 D   3 0 4 9 1 8 4 2 5 2 

日付は数ヶ月続いています。
このシートから7月だけのデータを取り出し
別のBOOKのSheeet1に
日付 型番 あ い う え お
7/1  A  1 3 8 7 6
sheet2に
日付 か き く け こ
7/1  5 4 6 8  4
というふうに転記したいのですがVBAではどうするか教えてください。

よろしくお願いします。

【72454】Re:転記したい
発言  UO3  - 12/8/13(月) 14:08 -

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

エクセルのバージョンはいくつですか?

それと、
>というふうに転記したいのですがVBAではどうするか教えてください。

VBAではと記述しておられますね。
ということは、エクセル上の操作では、できるということですよね?

それであれば、その操作をマクロ記録してみましょう。
基本的なコードが生成されますよ。

【72455】Re:転記したい
質問  うさこ  - 12/8/13(月) 14:13 -

引用なし
パスワード
   ▼UO3 さん:
>▼うさこ さん:
>
>エクセルのバージョンはいくつですか?
>2010です。

>それと、
>>というふうに転記したいのですがVBAではどうするか教えてください。
>
>VBAではと記述しておられますね。
>ということは、エクセル上の操作では、できるということですよね?
>
>それであれば、その操作をマクロ記録してみましょう。
>基本的なコードが生成されますよ。
そうなんですが、オートフィルターを使わないでVBAでやれといわれて
つたない知識で困っているのです・・・。

【72456】Re:転記したい
発言  UO3  - 12/8/13(月) 14:27 -

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

>そうなんですが、オートフィルターを使わないでVBAでやれといわれて
>つたない知識で困っているのです・・・。

もし、指示した人がいじわるで(?)、コードとしてオートフィルターを使うな、
別の方法で考えろということをいっているのであれば別ですが、
処理としてVBAでやればいいのですよね?
なので、VBAの中でオートフィルターを使って、抽出されたものをコピペという
コードにすればよろしいのでは?

で、そのあたりのコードは、(基本的な部分は)マクロ記録でできますよと申し上げています。
まず、そこまでやってみてはいかがでしょう。

もちろん、おやりになって、さらに壁があればお手伝いしますよ。
そのほうが、いきなりコードを差し上げるよりよろしいかと思いますが。

で、指示した人の条件で、VBAといえども、オートフィルター機能は使っちゃいけない
というものであれば、それはそれで、対応案コードをアップしますが?

【72457】Re:転記したい
発言  UO3  - 12/8/13(月) 14:29 -

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

追伸です。
同じフィルター機能でも、本件は、フィルターオプションのほうが適しているかもしれません。

いずれにしても、エクセルのバージョンは 2007以降ですか?
2003以前ですか?

【72458】Re:転記したい
質問  うさこ  - 12/8/13(月) 14:57 -

引用なし
パスワード
   ▼UO3 さん:
エクセルのバージョンは2010です。
フィルターをかけた後にさらに、特定の列のデータだけをコピーして
転記します。
マクロの記録でやってみます・・・。

【72461】Re:転記したい
質問  うさこ  - 12/8/13(月) 16:36 -

引用なし
パスワード
   へんなコードで笑われると思いますが
作ってみたのがこれですがこれだと最初に見つかった7月のデータしか
Sheet2にコピーされません・・・。
 Public Sub 練習()
  Dim 月 As String
  Dim 実行 As String
  Dim i As Integer
  Dim n As Integer
  

'抽出データ取得
  月 = ActiveCell.Value
  
'プログラムの実行確認メッセージ
  実行 = MsgBox(月 & " 月のデータを抽出しますか?", vbYesNo)
If 実行 = vbYes Then

For i = 2 To Sheets(1).Cells(Rows.Count, 6).End(xlUp).Row


If Format(Cells(i, 6), "m") = 7 Then
Rows(i).Copy
Sheets(2).Select
  ActiveSheet.Paste

  i = i + 1

End If
Next

  End If
End Sub

【72462】Re:転記したい
発言  Yuki  - 12/8/13(月) 16:51 -

引用なし
パスワード
   ▼うさこ さん:
横から失礼
AutoFilterで年月日の月データを表示するには
下記のようにします。
サンプルをあげておきます。
Sheet1はデータ
Sheet2からは抽出データ

Sub Macro1()
  Dim lCol  As Long
  Dim lPage  As Long
  Dim sht   As Worksheet
  Dim i    As Long
  Dim sS   As String
  Dim sE   As String
  Dim inPage As Long
  
  sS = InputBox("処理開始年月日を入力", "処理開始年月日", DateSerial(Year(Date), Month(Date), 1))
  sE = DateSerial(Year(CDate(sS)), Month(CDate(sS)) + 1, 1 - 1)
  
  inPage = 5 '区切りの列数
  With Worksheets("Sheet1")
    lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    lPage = Fix((lCol - 2) / inPage + 0.999999)  'シート数
    .AutoFilterMode = False
    With .Range("A1").CurrentRegion
      .AutoFilter Field:=1, Criteria1:=">=" & sS, Operator:=xlAnd, _
                 Criteria2:="<=" & sE
      For i = 1 To lPage
        ' シートの有無の確認         
        On Error Resume Next
        Set sht = Worksheets("Sheet" & i + 1)
        If Err.Number <> 0 Then
          ' 無かった追加
          Set sht = Worksheets.Add(After:=Worksheets(Worksheets.Count))
          sht.Name = "Sheet" & i + 1
        End If
        sht.Cells.Clear
        Set sht = Nothing
        .SpecialCells(xlCellTypeVisible).Copy _
          Worksheets("Sheet" & i + 1).Range("A1")
        
        With Worksheets("Sheet" & i + 1)
          .Columns(i * inPage + 3).Resize(, inPage * (lPage - 1)).Delete
          .Columns(3).Resize(, (i - 1) * inPage).Delete
        End With
      Next
    End With
    .AutoFilterMode = False
  End With
End Sub

【72465】Re:転記したい
発言  UO3  - 12/8/13(月) 17:19 -

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

コード案を2つほどアップします。
ご参考まで。(急いで書いたので結構、処理効率は悪いです。)
ほんとは、フィルタオプションが適していると思います。
もし、ご興味があれば、そのバージョンを書いてアップします。

Sub Sample1()  'オートフィルター
  Dim yy As Long
  Dim mm As Long
  
  Application.ScreenUpdating = False
  
  yy = 2012
  mm = 7

  With Sheets("Sheet1")
    .AutoFilterMode = False '設定されていればいったん解除
    .Range("A1").AutoFilter
    
    .AutoFilter.Range.AutoFilter Field:=1, _
      Criteria1:=">=" & CDbl(DateSerial(yy, mm, 1)), Criteria2:="<" & CDbl(DateSerial(yy, mm + 1, 1)), Operator:=xlAnd
  
    .UsedRange.Copy Sheets("Sheet2").Range("A1")
    .UsedRange.Copy Sheets("Sheet3").Range("A1")
    
    .AutoFilterMode = False
    
  End With
  
  Sheets("Sheet2").Columns("H:L").Delete
  Sheets("Sheet3").Columns("C:G").Delete
  
  Application.ScreenUpdating = True
  
End Sub

Sub Sample2()  'フィルターを使わない(上司の命令?)
  Dim v() As Variant
  Dim c As Range
  Dim k As Long
  Dim yy As Long
  Dim mm As Long
  Dim fdate As Date
  Dim tdate As Date
  
  Application.ScreenUpdating = False
  
  yy = 2012
  mm = 7

  fdate = DateSerial(yy, mm, 1)
  tdate = DateSerial(yy, mm + 1, 1)
  
  With Sheets("Sheet1")
    ReDim v(1 To .Rows.Count)
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
      If c.Value >= fdate And c.Value < tdate Then
        k = k + 1
        v(k) = c.EntireRow.Range("A1:L1").Value
      End If
    Next
  End With
  
  ReDim Preserve v(1 To k)
  
  With Sheets("Sheet2")
    .Cells.ClearContents
    .Range("A1:L1").Value = Sheets("Sheet1").Range("A1:L1").Value
    .Range("A2").Resize(k, 12).Value = _
      WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))
    .UsedRange.Copy Sheets("Sheet3").Range("A1")
  End With
  
  Sheets("Sheet2").Columns("H:L").Delete
  Sheets("Sheet3").Columns("C:G").Delete
  
  Application.ScreenUpdating = True
  
End Sub

【72467】Re:転記したい
発言  UO3  - 12/8/13(月) 17:36 -

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

フィルターオプション版もアップしておきますね。

Sub Sample3()  'フィルタ−オプション
  Dim yy As Long
  Dim mm As Long
  Dim t1 As Variant
  Dim t2 As Variant
  Dim t3 As Variant
  
  Application.ScreenUpdating = False
  
  yy = 2012
  mm = 7

  With Sheets("Sheet1")
    .Range("N1:O1").Value = .Range("A1").Value
    .Range("N2").Value = ">=" & CDbl(DateSerial(yy, mm, 1))
    .Range("O2").Value = "<" & CDbl(DateSerial(yy, mm + 1, 1))
    t1 = .Range("A1:B1").Value
    t2 = .Range("C1:G1").Value
    t3 = .Range("H1:L1").Value
  End With
  
  With Sheets("Sheet2")
    .UsedRange.ClearContents
    .Range("A1:B1").Value = t1
    .Range("C1:G1").Value = t2
    Sheets("Sheet1").Columns("A:L").AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=Sheets("Sheet1").Range("N1:O2"), CopyToRange:=.Range("A1:G1") _
      , Unique:=False
  End With
  
  With Sheets("Sheet3")
    .UsedRange.ClearContents
    .Range("A1:B1").Value = t1
    .Range("C1:G1").Value = t3
    Sheets("Sheet1").Columns("A:L").AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=Sheets("Sheet1").Range("N1:O2"), CopyToRange:=.Range("A1:G1") _
      , Unique:=False
  End With
  
  Sheets("Sheet1").Range("N1:O2").Clear
  
  Application.ScreenUpdating = True
  
End Sub

【72468】Re:転記したい
発言  kanabun  - 12/8/13(月) 17:50 -

引用なし
パスワード
   ▼うさこ さん:
おじゃまします。
こういうのは、ぼくなら(ぼくも)フィルタオプションでやります
UO3 さんがすでにサンプルコードを投稿されてますが、
同じではないと思うので、こちらの例を

Sub Try1()
  Dim WS1 As Worksheet
  Dim WS2 As Worksheet
  Dim WS3 As Worksheet
  
  Set WS1 = Workbooks("転記元Book.xls").Worksheets("Sheet1") '【要変更】
  Set WS2 = Workbooks("転記先Book.xls").Worksheets("Sheet1")'【要変更】
  Set WS3 = Workbooks("転記先Book.xls").Worksheets("Sheet2")'【要変更】
  
  'WS1のQ列に抽出条件を書き込む
  Dim CrRange As Range
  Set CrRange = WS1.[Q1:Q2]
  With CrRange
    .ClearContents
    .Item(2).Formula = "=MONTH(A2)=7" '[Q2]に 7月の行を抽出式
  End With
  '抽出先に 転記したい項目をコピー (Sheet1の方)
  Dim CopyTo As Range
  Set CopyTo = WS2.[A1].Resize(, 7)
  With WS1.[A1]
    .Resize(, 7).Copy CopyTo
    .CurrentRegion.AdvancedFilter xlFilterCopy, CrRange, CopyTo
  End With
  
  '抽出先に 転記したい項目をコピー (Sheet2の方)
  Set CopyTo = WS3.[A1].Resize(, 6)
  WS3.[A1].Value = WS1.[A1].Value
  WS1.[H1].Resize(, 5).Copy WS3.[B1]
  WS1.[A1].CurrentRegion.AdvancedFilter xlFilterCopy, CrRange, CopyTo
  
End Sub

【72469】Re:転記したい
お礼  うさこ  - 12/8/13(月) 18:31 -

引用なし
パスワード
   みなさま
ほんとうにありがとうございます。
それぞれのパターンをこれから試してみたいと思います。
がんばってやってみます。

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