エクセルＶＢＡ複数ファイルのデータを１つのシートに

質問

(1)サーバー上にある圧縮ファイルをダウンロード
（ＵＲＬはエクセルの一覧表をクリック）※図Ａ
(2)ダウンロードした圧縮ファイル（ZIP形式）を解凍する
(3)エクセルファイルを開いて範囲を指定してコピー
（コピーする範囲はB2:C101の100行2列のデータ）※図Ｂ
(4)コピーしたデータを別ファイルのエクセルシートにペースト
（シートは１枚、下に下に続けてペースト）
表にあるＵＲＬ一覧の最後まで(1)～(4)を繰り返す
（パソコン環境）
Windows10
Google Chrome
Excel2010

回答No.4

HohoPapa · ベストアンサー

ならば、
　　　With ThisWorkbook.Sheets(2)
　　　　Set TRange = Range(.Cells((RowCnt - 1) * CpyCnt + 2, 2), _
　　　　　　.Cells((RowCnt) * CpyCnt + 1, 3))
　　　End With
　　　Set FRange = Range(tgSheet.Cells(1, 2), tgSheet.Cells(CpyCnt, 3))
　　　TRange.Value = FRange.Value
を
　　　With ThisWorkbook.Sheets(2)
　　　　If RowCnt = 1 Then
　　　　　Set TRange = Range(.Cells(1, 1), _
　　　　　　.Cells(CpyCnt + 1, 3))
　　　　　Set FRange = Range(tgSheet.Cells(1, 1), tgSheet.Cells(CpyCnt + 1, 3))
　　　　Else
　　　　　Set TRange = Range(.Cells((RowCnt - 1) * CpyCnt + 2, 2), _
　　　　　　.Cells((RowCnt) * CpyCnt + 1, 3))
　　　　　Set FRange = Range(tgSheet.Cells(2, 2), tgSheet.Cells(CpyCnt + 1, 3))
　　　　End If
　　　End With
　　　TRange.Value = FRange.Value
に
直せば期待の結果になると思います。

お礼

ありがとうございます。
完璧です。
期待通りのことができるようになりました。
いろいろとお手数お掛けいたしました。

回答No.3

HohoPapa

http://xxx.com/23156.zip これをダウンロードして解凍したときの
エクセルのレイアウトは
1行目がタイトル、
2行目以下がデータの羅列
ですか？

複写先のレイアウトは
1行目がタイトル、
2行目以下が全数データの羅列
になることを期待していますか？

ならば、

複写元１つめのファイルの1つ目のシートは
複写元の1行目から101行を
複写先の1行目以下に複写

複写元２つめのファイルの1つ目のシートは
複写元の2行目から100行を
複写先の102行以下に複写

複写元3つめのファイルの1つ目のシートは
複写元の2行目から100行を
複写先の202行以下に複写

といった複写を期待していますか？

お礼

何度も申し訳ございません。
説明不足を補完していただきありがとうございます。
その通りでございます。

回答No.2

HohoPapa

ごめんなさい、コードを間違えています。

　　　With ThisWorkbook.Sheets(2)
　　　　Set TRange = Range(.Cells((RowCnt - 1) * CpyCnt + 1, 2), _
　　　　　　.Cells((RowCnt) * CpyCnt + 1, 3))
　　　End With
　　　Set FRange = Range(tgSheet.Cells(1, 2), tgSheet.Cells(CpyCnt + 1, 3))
　　　TRange.Value = FRange.Value

は誤りで、以下が訂正後です。

　　　With ThisWorkbook.Sheets(2)
　　　　Set TRange = Range(.Cells((RowCnt - 1) * CpyCnt + 2, 2), _
　　　　　　.Cells((RowCnt) * CpyCnt + 1, 3))
　　　End With
　　　Set FRange = Range(tgSheet.Cells(1, 2), tgSheet.Cells(CpyCnt, 3))
　　　TRange.Value = FRange.Value

で、

Const CpyCnt = 101 '複写行数100?と変更しました。
これは
Const CpyCnt = 100 '複写行数
としてください。

お礼

お手数お掛けしております。
２回目のご回答ありがとうございます。

早速、ご指示の点、修正させていただきました。
「Const CpyCnt = 100」にしています。

番号はA列の数値です。

番号1の行（セルB2C2）が空白になり、
番号2の行（セルB3C3）からデータが始まっています。

データを見るとコピーはできているようです。
ペーストする際に１番目のデータがB2C2ではなく、B3C3からはじまっているようです。

データの終わりの箇所は、
番号100　99行目のデータ
番号101　空白
番号102　次の100個のデータの1番目のデータ

100行目のデータが抜けた状態になっております。

回答No.1

HohoPapa

適当なダウンロードサイトがなかったので、
ほぼ机上デバックのみしか行っていません。
また、当方の環境はOffice2019です。
使っているブラウザには依存しないはずです。

http://xxx.com/23156.zip これをダウンロードして解凍したときに
フォルダー構成だったり、複数ファイルだったりするのではなく
単に、23156.xlsx　が作成される前提です。

WshShellの参照設定してください。
つまり、VBA画面→ツールメニュー→参照設定で「Windows Script Host Object Model」を選択します。

Option Explicit

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
　 (ByVal pCaller As Long, _
　　ByVal szURL As String, _
　　ByVal szFileName As String, _
　　ByVal dwReserved As Long, _
　　ByVal lpfnCB As Long) As Long

Sub sample()

　Const PutDir = "C:\work"　'ダウンロード先フォルダー
　Const CpyCnt = 7　　 '複写行数　100?

　Dim FNameSNum As Long
　Dim FNameL As String
　Dim FNameS As String
　Dim LenFName As Long
　Dim tgUrl As String
　Dim tgBook As Workbook
　Dim tgSheet As Worksheet
　Dim RowCnt As Long
　Dim FRange As Range
　Dim TRange As Range
　Dim i As Long
　Dim FSO As Object
　Set FSO = CreateObject("Scripting.FileSystemObject")

　ThisWorkbook.Sheets(2).Cells.ClearContents

　With ThisWorkbook.Sheets(1)

　　RowCnt = 1

　　Do

　　　If .Cells(RowCnt, 1).Value = "" Then Exit Do

　　　'Urlからファイル名算出
　　　tgUrl = .Cells(RowCnt, 1).Value
　　　LenFName = Len(tgUrl)
　　　FNameSNum = InStrRev(tgUrl, "/")
　　　FNameL = Mid(tgUrl, FNameSNum + 1, LenFName)
　　　FNameS = FSO.GetBaseName(FNameL)

　　　'ダウンロード
　　　Download_File tgUrl, PutDir & "\" & FNameL

　　　'解凍
　　　UnZip PutDir & "\" & FNameL, PutDir

　　　'ファイルを開き、データを取得し、自身シート2枚目に追記
　　　Set tgBook = Workbooks.Open(PutDir & "\" & FNameS & ".xlsx")
　　　Set tgSheet = tgBook.Sheets(1)

　　　With ThisWorkbook.Sheets(2)
　　　　Set TRange = Range(.Cells((RowCnt - 1) * CpyCnt + 1, 2), _
　　　　　　.Cells((RowCnt) * CpyCnt + 1, 3))
　　　End With
　　　Set FRange = Range(tgSheet.Cells(1, 2), tgSheet.Cells(CpyCnt + 1, 3))
　　　TRange.Value = FRange.Value

　　　tgBook.Close

　　　RowCnt = RowCnt + 1

　　Loop

　End With

　With ThisWorkbook.Sheets(2)
　　.Cells(1, 1).Value = "番号"
　　.Cells(1, 2).Value = "品名"
　　.Cells(1, 3).Value = "色"
　　For i = 2 To (RowCnt - 1) * CpyCnt + 1
　　　.Cells(i, 1).Value = i - 1
　　Next i
　End With

End Sub

'//----------------------ダウンロードサブルーチン
Sub Download_File(strURL As String, strPath As String)

　Dim lngRes As Long

　lngRes = URLDownloadToFile(0, strURL, strPath, 0, 0)
　If lngRes <> 0 Then
　　MsgBox "ダウンロード失敗"
　　Exit Sub
　End If

End Sub

'//----------------------解凍関数
Function UnZip(a_sZipPath As String, a_sExpandPath As String) As Boolean
　Dim sh　　　As New IWshRuntimeLibrary.WshShell
　Dim ex　　　As WshExec
　Dim sCmd　　As String

　'// 半角スペースをバッククォートでエスケープ
　a_sZipPath = Replace(a_sZipPath, " ", "` ")
　a_sExpandPath = Replace(a_sExpandPath, " ", "` ")

　'// Expand-Archive：解凍コマンド
　'// -Path：フォルダパスまたはファイルパスを指定する。
　'// -DestinationPath：生成ファイルパスを指定する。
　'// -Force：生成ファイルが既に存在している場合は上書きする
　sCmd = "Expand-Archive -Path " & a_sZipPath & " -DestinationPath " & a_sExpandPath & " -Force"

　'// コマンド実行
　Set ex = sh.Exec("powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & sCmd)

　'// コマンド失敗時
　If ex.Status = WshFailed Then
　　'// 戻り値に異常を返す
　　UnZip = False
　　'// 処理を抜ける
　　Exit Function
　End If

　'// コマンド実行中は待ち
　Do While ex.Status = WshRunning
　　DoEvents
　Loop

　'// 戻り値に正常を返す
　UnZip = True
End Function

お礼

早々にありがとうございます。
１００行ずつコピーしたいので、
Const CpyCnt = 101 '複写行数100?と変更しました。
これで試してみました。
Sheet2を見てみると100行ずつペーストされているのですが、
ペーストするごとに（100行ごとに）１行のスペースが空いています。
このスペースを空けることなく、続けてペーストできるようにしたいと思っています。
どうにか自分でやろうとしたのですが、挫折しています。
どうかご教授いただければと思います。

補足

ご回答ありがとうございます。
１つ目の100個のデータと２つ目の100個のデータの間は、
行を空けることなく詰めてペーストしたいと考えています。

「Const CpyCnt = 100　にした場合」
・ペーストされているデータは９９行（１行足りない）
・次のデータとの間に１行スペースがある

「Const CpyCnt = 101　にした場合」
・ペーストされているデータは１００行（ＯＫ！）
・次のデータとの間に１行スペースがある