[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『A表からB表へコピーするコードについて』（わわ）
下記のコードを書きましたがそもそもの構成が違うようなエラーが出てしまいます。
「管理表」に日々の情報を入力、
その後、M1からN1の期間、尚且つ100円以上200円以下の条件で、見積金額と受注金額を「提出用の表」にコピペしたいのです。 ただ、「提出用の表」に直接入れるコードをかけないので、「提出用の表」横に一旦抽出し、関数で引っ張っていますので、正しくいうと「提出用の表の横」という事になります。ややこしくてすみません。
管理表
a b c d e 1 商品 見積日 見積金額 受注日 受注金額 2 ぺん 7月10日 110 3 のり 7月10日 120 7月12日 120 4 はさみ 7月4日 150 7月15日 150 5 ふせん 7月12日 250
提出用の表
m n 1 7月10日 7月15日
ｇ ｈ i j k 商品 見積日 見積金額 受注日 受注金額 1 ぺん 7月10日 110 2 のり 7月10日 120 3 のり 7月12日 120 4 はさみ 7月15日 150 5
Sub 提出用の表()
Dim sh As Worksheet
Worksheets("提出用の表").Activate
Worksheets("提出用の表").Range("G2:Z100").Clear
For Each sh In Worksheets
Select Case sh.Name
Case "管理表"
With sh.Range("A1")
.AutoFilter Field:=2, Criteria1:=">=" & Range("M1").Value, Operator:=xlAnd, Criteria2:="<=" & Range("N1").Value
.AutoFilter Field:=3, Criteria1:=">=100", Operator:=xlAnd, Criteria2:="<=200"
If Range("D1").Value <> "" Then
.CurrentRegion.Offset(1).SpecialCells(xlVisible).Copy
Else
.CurrentRegion.Offset(1).SpecialCells(xlVisible).Copy
.Columns("D:E").ClearContents
End If
Sheets("提出用の表").Range("G" & Rows.Count).End(xlUp).Offset (1)
.AutoFilter
End With
Case Else
End Select
Select Case sh.Name
Case "管理表"
With sh.Range("A1")
.AutoFilter Field:=4, Criteria1:=">=" & Range("M1").Value, Operator:=xlAnd, Criteria2:="<=" & Range("N1").Value
.AutoFilter Field:=5, Criteria1:=">=100", Operator:=xlAnd, Criteria2:="<=200"
If Range("B1").Value <> "" Then
.CurrentRegion.Offset(1).SpecialCells(xlVisible).Copy
Else
.CurrentRegion.Offset(1).SpecialCells(xlVisible).Copy
.Columns("B:C").ClearContents
End If
Sheets("提出用の表").Range("G" & Rows.Count).End(xlUp).Offset (1)
.AutoFilter
End With
Case Else
End Select
修正または正しいコードをご教授いただけますでしょうか。
どうぞ宜しくお願い致します。
＜ 使用 Excel：unknown、使用 OS：Windows7 ＞
Dim c As Range, r As Range
With Sheets("提出用の表")
.Range("A:E").Cells.Clear
.Range("A1:E1").Value = Sheets("管理表").Range("A1:E1").Value
For Each c In Sheets("管理表").Range("B:E").SpecialCells(2)
If IsDate(c.Value) And c.Value >= .Range("M1").Value And c.Value <= .Range("N1").Value And c.Offset(, 1).Value >= 100 And c.Offset(, 1).Value <= 200 Then
Set r = .Range("A" & Rows.Count).End(xlUp).Offset(1)
r.Value = c.EntireRow.Cells(1).Value
r.Offset(, c.Column - 1).Resize(, 2).Value = Array(c.Value, c.Offset(, 1).Value)
End If
Next c
End With
End Sub
（mm） 2018/07/25(水) 13:07
二つ以上のシートを操作するときは、シート名を指定したほうが安全ですよ。
Sub 回答例()
Dim 管理 As Worksheet, 提出 As Worksheet
Set 管理 = ThisWorkbook.Sheets("管理表")
Set 提出 = ThisWorkbook.Sheets("提出用の表")
If IsDate(提出.Range("M1").Value) = False Or IsDate(提出.Range("N1").Value) = False Then
MsgBox "期間を正しく入力してください"
Exit Sub
End If
提出.Range("G:K").ClearContents
With 管理.Range("A1")
If 管理.AutoFilterMode Then .AutoFilter
.AutoFilter Field:=2, Criteria1:=">=" & 提出.Range("M1").Value, _
Operator:=xlAnd, Criteria2:="<=" & 提出.Range("N1").Value
.AutoFilter Field:=3, Criteria1:=">=100", Operator:=xlAnd, Criteria2:="<=200"
.CurrentRegion.Copy 提出.Range("G1")
End With
End Sub
（TAKA） 2018/07/25(水) 13:33
Dim c As Range, r As Range
With Sheets("提出用の表")
.Range("G:K").Cells.Clear
.Range("G1:K1").Value = Sheets("管理表").Range("A1:E1").Value
For Each c In Sheets("管理表").Range("B:E").SpecialCells(2)
If IsDate(c.Value) And c.Value >= .Range("M1").Value And c.Value <= .Range("N1").Value And c.Offset(, 1).Value >= 100 And c.Offset(, 1).Value <= 200 Then
Set r = .Range("G" & Rows.Count).End(xlUp).Offset(1)
r.Value = c.EntireRow.Cells(1).Value
r.Offset(, c.Column - 1).Resize(, 2).Value = Array(c.Value, c.Offset(, 1).Value)
End If
Next c
End With
End Sub
（mm） 2018/07/25(水) 13:46
ご返信大変感謝しております。
ありがとうございます。
TAKA様
自分のやり方が悪いのか、受注額が見積額と横並びになりはさみが抜けて
提出の表通りに表示されませんでした。
しかし、とても分かり易いので応用できればと思います。
mm様
上手く提出の表通りに表示できました、ありがとうございます。
ただ、実際の表は、文字が入ってる列・日付が複数あり、金額の列も日付の次ではない為offsetが使えず
mm様のコードを理解しながらセルや数字を変更していましたが、どうしても
・文字や日付があるセルは一列しかコピペすることができません。
下記の場合ですとどのようになるのか、
どうぞ宜しくお願い致します。
管理表
a b c d e f g h i j k
商品1 その1 その2 その3 その4 見積金額1見積金額2見積金額3見積金額4見積日1見積日2
ぺん 110 10 10 10 7月10日 7月10日
のり 120 10 10 10 7月10日 7月10日
はさみ 150 10 10 10 7月4日 7月4日
ホッチキス 250 10 10 10 7月12日 7月12日
（表は横に続ます）
l m n o p q r s t u v
その5 その6 その7 その8 その9 その10 その11 その12 受注金額受注日1 受注日2
120 7月12日 7月12日
150 7月15日 7月15日
提出用の表
商品 見積日1 見積金額1受注日 受注金額 1 ぺん 7月10日 110 2 のり 7月10日 120 3 のり 7月12日 120 4 はさみ 7月15日 150 5
（わわ） 2018/07/26(木) 15:24
こんな方法もあります。
Sub test()
Dim cn As Object, rs As Object, sDate As String, eDate As String, i As Long
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
With cn
.Provider = "Microsoft.Ace.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1;"
.Open ThisWorkbook.FullName
End With
With Sheets("提出用の表")
sDate = Format$(.Range("m1").Value, "yyyy/mm/dd")
eDate = Format(.Range("n1").Value, "yyyy/mm/dd")
.Cells(1).CurrentRegion.Resize(, 11).ClearContents
rs.Open "Select 商品1 As 商品, 見積日1, 見積金額1, Null As 受注日, Null As 受注金額 From `管理表$` " & _
"Where 見積金額1 Between 100 And 200 And 見積日1 >= #" & sDate & "# And 見積日1 <= #" & eDate & "#", cn, 3
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1).Value = rs.Fields(i).Name
Next
.[a2].CopyFromRecordset rs: rs.Close
rs.Open "Select 商品1, Null As 見積日1, Null As 見積金額1, 受注日1 As 受注日, 受注金額 From `管理表$` " & _
"Where 受注金額 Between 100 And 200 And 受注日1 >=#" & sDate & "# And 受注日1 <=#" & eDate & "#", cn, 3
.Range("a" & Rows.Count).End(xlUp)(2).CopyFromRecordset rs
End With
Set cn = Nothing: Set rs = Nothing
End Sub
（seiya） 2018/07/26(木) 17:21
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.