| |
Sub MyShop_SaleData()
Dim MyF As String
Dim CkC As Variant
Dim WS As Worksheet
Dim xR As Long
Dim C As Range
Dim セル,xC,S,CC as variant
Const Ph As String = _
"C:\Documents and Settings\User\My Documents\ExcelFiles\"
Application.ScreenUpdating = False
Set WS = ThisWorkbook.Worksheets(1)
MyF = Dir(Ph & "*.xls")
Do Until MyF = ""
xR = WS.Cells(65536, 1).End(xlUp).Row + 1
WS.cells(xR,1).value=Left$(MyF,Len(MyF)-4)
Workbooks.Open Ph & MyF
With ActiveWorkbook
For Each C In .Worksheets(1).range("A1:M1").SpecialCells(2)
CkC = Application.Match(C.Value, WS.Range("A1:X1"), 0)
If Not IsError(CkC) Then
WS.Cells(xR, CkC).Value = C.Offset(1).Value
thedate=Datepart("yyyy",Date) & "年" & Datepart("m",Date) &"月"
set セル=.worksheets(1).range("A1:M1").find(thedate,lookin:=xlvalues)
set cc=WS.range("A1:X1").find(thedate,lookin:=xlvalues)
If not セル is nothing then
xR = WS.Cells(65536, 1).End(xlUp).Row
xC=cc.column
S=.range(セル,"M1").columns.count
WS.range(xR,xC),resize(,S).value=.cells(1,セル.column).offset(2).resize(,S).value
End If
End if
Next
.Close False
End With
MyF = Dir()
Loop
Application.ScreenUpdating = True: Set WS = Nothing
MsgBox "データの転記を完了しました", 64
End Sub
新宿支店.xls
A B C D E・・・・・・・M列
2007年2月 2007年3月 2007年4月 2007年5月・・・2008年1月
売上実績 250 230 0 0
売上目標 200 220 300 300
池袋支店.xls
A B C D E・・・・・・・M列
2007年3月 2007年4月 2007年5月 2007年6月・・・2008年2月
売上実績 250 200 0 0
売上目標 200 200 250 300
↓
転記先.xls
A B C D E・・・・・・・・・X列
2007年2月 2007年3月 2007年4月 2007年5月 2007年6月・・
新宿 250 230 300 300
池袋 250 200 250 300
売上実績を転記する方法を48324の質問でさせていただきました。
現在の月（今なら2007年4月）よりあとの部分については売上目標の数字を転記したく、書いてみました。
しかし、2007年4月以降の分についてはresizeで数字を転記するため
転記先のX列を超えて数字が転記されてしまいます。
ここはどう変えるとX列までの転記でいけるのでしょうか。
何卒ご教授頂きたいと思います。
宜しくお願い致します。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
