合計一覧より参照 表記excel2007VBA

質問

シート1に各月の売上一覧が毎月更新されていきます。

シート2のC1に　○月売上を指定し、B列に表記したいと考えています。

よろしくお願いします。

回答No.3

kkkkkm · ベストアンサー

> 例えば、1月売上→2016/1/20　と直した場合

Sheet1,Sheet2のどちらを直したのかわからないので、3パターン記載しておきます。

'Sheet2もSheet1も2016/2/20など同じ日付
Sub Example()
Dim MyColumn As Long
Dim ws1 As Worksheet, ws2 As Worksheet

On Error Resume Next
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

MyColumn = WorksheetFunction.Match(ws2.Range("C1").Value2, ws1.Range("1:1"), 0)
'↑もしくはws2.Range("C1").Value2をws2.Range("C1")に
ws1.Cells(1, MyColumn).Resize(11, 1).Copy ws2.Range("B1")

Set ws1 = Nothing
Set ws2 = Nothing
End Sub

'Sheet2が○月売上Sheet1が2016/2/20など日付
Sub Example2()
Dim MyLastColumn As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim SearchStr As String
Dim c As Range

Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

SearchStr = Left(ws2.Range("C1").Value, InStr(ws2.Range("C1").Value, "月") - 1)
'Sheet2が2016/2/20など日付Sheet1が○月売上の場合は
'SearchStr = Month(ws2.Range("C1").Value) & "月売上"

With ws1
MyLastColumn = .Cells(1, Columns.Count).End(xlToLeft).Column
For Each c In .Range(.Cells(1, "B"), .Cells(1, MyLastColumn))
If Month(c.Value) = SearchStr Then
'Sheet2が2016/2/20など日付Sheet1が○月売上の場合は
'If c.Value = SearchStr Then
.Cells(1, c.Column).Resize(11, 1).Copy ws2.Range("B1")
Exit For
End If
Next
End With
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

お礼

1パターンでさせて頂きました！
ご丁寧にありがとうございます。

回答No.6

kagakusuki

>シート2の”Ｃ”列と順に転記されていく方法なんですね。

　その通りです。

>”Ｃ1”の値を”シート1”からＢ列に読み込むだけでよかったのですが、

　済みません。「シート1”からＢ列に読み込むだけ」ならばC1セルではなくB1セルに値を入力しておいて、2行目以下の値だけを転記させれば良い様に思えたため、

>B列に表記したい

と書いておられるのにも関わらず、

>シート2のC1に

となっているのは単なる入力ミスの類だと思い込んでおりました。

回答No.5

kagakusuki

回答No.2,4です。

　回答No.4を回答した時には、自分の回答に対して投稿されて来たお礼コメントしか読んでいなかったのですが、

>例えば、1月売上→2016/1/20　と直した場合、ＶＢＡ表記されなくなってしまいました…。

という問題もあったのですね。
　それでその場合、「2016/1/20」に直したというお話は、Sheet1とSheet2のそれぞれに1枚ずつ設けられている表の、両方の1行目の値を直したという事であると考えて宜しいのでしょうか？
　「片方だけが『2016/1/20』に直されていて、もう一方は『1月売上』のままである」という訳ではないと考えて宜しいのでしょうか？
　もし両方の表において1行目の値が「2016/1/20」などの様になっている場合には、一例としては次の様なVBAのマクロになります。

Sub QNo9219574_合計一覧より参照_表記excel2007VBA_改()

Dim i As Long, c As Range, SheetName(1, 1) As String, MySheet(1) As Worksheet, _
ItemRow(1) As Long, ItemColumn(1) As String, myColumns As Long, _
myRows As Long, LastRow As Long, LastColumn As Long, buf As Variant

SheetName(0, 0) = "Sheet1" '元データの表が存在するシートのシート名
SheetName(0, 1) = "元データが入力されている" '元データの表が存在するシートの説明文
SheetName(1, 0) = "Sheet2" '新たに表を作成するシートのシート名
SheetName(1, 1) = "データの転写先" '新たに表を作成するシートの説明文
ItemRow(0) = 1 '元データの表において項目名が入力されている行
ItemRow(1) = 1 '新たに作成する表において項目名が入力されている行
ItemColumn(0) = "A" '元データの表において顧客名が入力されている列
ItemColumn(1) = "A" '新たに作成する表において顧客名が入力されている列

For i = 0 To 1
If IsError(Evaluate("ROW('" & SheetName(i, 0) & "'!A1)")) Then
MsgBox SheetName(i, 1) & "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & SheetName(i, 0) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set MySheet(i) = Sheets(SheetName(i, 0))
Next i

For i = 0 To 1
With MySheet(i)
LastRow = .Range(ItemColumn(i) & Rows.Count).End(xlUp).row
LastColumn = .Cells(ItemRow(i), Columns.Count).End(xlToLeft).column
If LastRow <= ItemRow(i) Or LastColumn <= .Columns(ItemColumn(i)).column Then
MsgBox "処理すべき元データが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
End With
Next i
myRows = LastRow - ItemRow(1)
myColumns = LastColumn - MySheet(1).Columns(ItemColumn(1)).column

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

MySheet(1).Range(ItemColumn(1) & ItemRow(1)).Offset(1, 1) _
.Resize(myRows, myColumns).ClearContents
For Each c In MySheet(1).Range(ItemColumn(1) & ItemRow(1)).Offset(0, 1).Resize(1, myColumns)
buf = c.Value
If buf <> "" And WorksheetFunction.CountIf(MySheet(0).Range( _
ItemColumn(0) & ItemRow(0)).Offset(0.1).Resize(1, 12), buf) > 0 Then
If IsDate(buf) Then buf = CDbl(buf)
c.Offset(1).Resize(myRows).Value = MySheet(0).Cells(ItemRow(0), WorksheetFunction _
.Match(buf, MySheet(0).Rows(ItemRow(0)), 0)).Offset(1).Resize(myRows).Value
End If
Next c

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

回答No.4

kagakusuki

回答No.2です。

>中程の　GoTo labelE　でエラーになってしまいます。

　失礼しました。回答欄に入力する際に　GoTo labelE　を使わない方法に修正しようとしたのですが、消し忘れた　GoTo labelE　がまだ残っておりました。
　その　GoTo labelE　の所を　Exit Sub　に差し換えて下さい。

Sub QNo9219574_合計一覧より参照_表記excel2007VBA()

Dim i As Long, c As Range, SheetName(1, 1) As String, MySheet(1) As Worksheet, _
ItemRow(1) As Long, ItemColumn(1) As String, myColumns As Long, _
myRows As Long, LastRow As Long, LastColumn As Long

SheetName(0, 0) = "Sheet1" '元データの表が存在するシートのシート名
SheetName(0, 1) = "元データが入力されている" '元データの表が存在するシートの説明文
SheetName(1, 0) = "Sheet2" '新たに表を作成するシートのシート名
SheetName(1, 1) = "データの転写先" '新たに表を作成するシートの説明文
ItemRow(0) = 1 '元データの表において項目名が入力されている行
ItemRow(1) = 1 '新たに作成する表において項目名が入力されている行
ItemColumn(0) = "A" '元データの表において顧客名が入力されている列
ItemColumn(1) = "A" '新たに作成する表において顧客名が入力されている列

For i = 0 To 1
If IsError(Evaluate("ROW('" & SheetName(i, 0) & "'!A1)")) Then
MsgBox SheetName(i, 1) & "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & SheetName(i, 0) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set MySheet(i) = Sheets(SheetName(i, 0))
Next i

For i = 0 To 1
With MySheet(i)
LastRow = .Range(ItemColumn(i) & Rows.Count).End(xlUp).row
LastColumn = .Cells(ItemRow(i), Columns.Count).End(xlToLeft).column
If LastRow <= ItemRow(i) Or LastColumn <= .Columns(ItemColumn(i)).column Then
MsgBox "処理すべき元データが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
End With
Next i
myRows = LastRow - ItemRow(1)
myColumns = LastColumn - MySheet(1).Columns(ItemColumn(1)).column

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

MySheet(1).Range(ItemColumn(1) & ItemRow(1)).Offset(1, 1) _
.Resize(myRows, myColumns).ClearContents
For Each c In MySheet(1).Range(ItemColumn(1) & ItemRow(1)).Offset(0, 1).Resize(1, myColumns)
If c.Value <> "" And WorksheetFunction.CountIf(MySheet(0).Range( _
ItemColumn(0) & ItemRow(0)).Offset(0.1).Resize(1, 12), c.Value) > 0 Then
c.Offset(1).Resize(myRows).Value = MySheet(0).Cells(ItemRow(0), WorksheetFunction _
.Match(c.Value, MySheet(0).Rows(ItemRow(0)), 0)).Offset(1).Resize(myRows).Value
End If
Next c

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

ありがとうございます。すごいです。
”Ｃ1”の値を”シート1”からＢ列に読み込むだけでよかったのですが、
シート2の”Ｃ”列と順に転記されていく方法なんですね。

他の時に応用させてください。

回答No.2

kagakusuki

以下の様なVBAマクロでは如何でしょうか？

Sub QNo9219574_合計一覧より参照_表記excel2007VBA()

Dim i As Long, c As Range, SheetName(1, 1) As String, MySheet(1) As Worksheet, _
ItemRow(1) As Long, ItemColumn(1) As String, myColumns As Long, _
myRows As Long, LastRow As Long, LastColumn As Long

SheetName(0, 0) = "Sheet1" '元データの表が存在するシートのシート名
SheetName(0, 1) = "元データが入力されている" '元データの表が存在するシートの説明文
SheetName(1, 0) = "Sheet2" '新たに表を作成するシートのシート名
SheetName(1, 1) = "データの転写先" '新たに表を作成するシートの説明文
ItemRow(0) = 1 '元データの表において項目名が入力されている行
ItemRow(1) = 1 '新たに作成する表において項目名が入力されている行
ItemColumn(0) = "A" '元データの表において顧客名が入力されている列
ItemColumn(1) = "A" '新たに作成する表において顧客名が入力されている列

For i = 0 To 1
If IsError(Evaluate("ROW('" & SheetName(i, 0) & "'!A1)")) Then
MsgBox SheetName(i, 1) & "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & SheetName(i, 0) & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
GoTo labelE
End If
Set MySheet(i) = Sheets(SheetName(i, 0))
Next i

For i = 0 To 1
With MySheet(i)
LastRow = .Range(ItemColumn(i) & Rows.Count).End(xlUp).row
LastColumn = .Cells(ItemRow(i), Columns.Count).End(xlToLeft).column
If LastRow <= ItemRow(i) Or LastColumn <= .Columns(ItemColumn(i)).column Then
MsgBox "処理すべき元データが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
End With
Next i
myRows = LastRow - ItemRow(1)
myColumns = LastColumn - MySheet(1).Columns(ItemColumn(1)).column

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

MySheet(1).Range(ItemColumn(1) & ItemRow(1)).Offset(1, 1) _
.Resize(myRows, myColumns).ClearContents
For Each c In MySheet(1).Range(ItemColumn(1) & ItemRow(1)).Offset(0, 1).Resize(1, myColumns)
If c.Value <> "" And WorksheetFunction.CountIf(MySheet(0).Range( _
ItemColumn(0) & ItemRow(0)).Offset(0.1).Resize(1, 12), c.Value) > 0 Then
c.Offset(1).Resize(myRows).Value = MySheet(0).Cells(ItemRow(0), WorksheetFunction _
.Match(c.Value, MySheet(0).Rows(ItemRow(0)), 0)).Offset(1).Resize(myRows).Value
End If
Next c

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

ありがとうございます。いつも勉強させていただいています。
中程の　GoTo labelE　でエラーになってしまいます。

回答No.1

kkkkkm

以下でどうでしょう。

Sub Example()
Dim MyColunm As Long
Dim ws1 As Worksheet, ws2 As Worksheet

On Error Resume Next
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")

MyColunm = WorksheetFunction.Match(ws2.Range("C1").Value, ws1.Range("1:1"), 0)
ws1.Cells(1, MyColunm).Resize(11, 1).Copy ws2.Range("B1")

Set ws1 = Nothing
Set ws2 = Nothing
End Sub

お礼

ありがとうございます。

例えば、1月売上→2016/1/20　と直した場合、ＶＢＡ表記されなくなってしまいました…。