| |
▼かつこ さん：
>追記。
>今回7月の欄も表示させました。
>1年分（4月〜翌年3月）まで書いてあります。
>7月分からは売上はないので0が入っています。
こういうのがダメな質問の仕方なんです。
回答する方は、提示されたデータ＆シートレイアウトでコードを書きます。
質問者は、提示されたコードを自分で改良して使おうと思っているのか解りませんが、
それだけのスキルが無く、後で
「実は○○になっていて、××なんです。教えてください。」
ってなことがやたらと多いんです。
更に途中でこうした方が良いかもなんて思うもんですから、何々を追加してください。
ってな事も起こることも多いです。
こうなるとあれですね....。
提示されたデータ分でしか考えてませんです。
Sub kousin()
Dim thename As String
Dim thedir As String
Dim thebook As Workbook
Dim AROW As Long
Dim i As Integer
Dim RRW As Variant, DNam As String
Const 確定月 As Integer = 5 '←確定は、１〜５月まで
Application.ScreenUpdating = False
'thedir = "C:\documents and settings\kousin"
thedir = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\kousin"
thename = Dir(thedir & "\*.xls")
'ThisWorkbook.Worksheets("一覧").Range("A2:D65536").ClearContents
Do While thename <> ""
If ThisWorkbook.Name <> thename Then
Set thebook = Workbooks.Open(thedir & "\" & thename)
AROW = ThisWorkbook.Worksheets("一覧").Range("A65536").End(xlUp).Row + 1
DNam = Left$(thename, Len(thename) - 4)
With thebook.Worksheets("データ")
i = 2
Do
If Val(.Cells(1, i).Value) > 確定月 Then
With ThisWorkbook.Worksheets("一覧")
RRW = Application.Match(DNam, .Columns(1), 0)
If Not IsError(RRW) Then
AROW = RRW
Else
.Cells(AROW, 1).Value = DNam
End If
.Cells(AROW, i).Value = thebook.Worksheets("データ").Cells(2, i).Value
End With
End If
i = i + 1
Loop Until .Cells(1, i).Value = Empty
End With
thebook.Close savechanges:=False
End If
thename = Dir()
Loop
Application.ScreenUpdating = True
End Sub
|
|
Jaka
- 07/6/5(火) 14:50 -
