●大量にある複数エクセルファイルの、特定シートの内容を、1つのシートに集約したい場合。

<具体例>
※転記元ファイルは下記では2つ挙げているが、
 マクロ内で、「test*.xls」のようにアスタリスクで複数ファイルを指定しているので、
 大量のエクセルファイルがあっても、それらが全て処理対象となる。

<転記元ファイル1つめ>
test1.xlsの、「項目一覧」シート
1-A11-B11-C11-D11-E11-F11-G1
1-A21-B21-C21-D21-E21-F21-G2
1-A31-B31-C31-D31-E31-F31-G3
1-A41-B41-C41-D41-E41-F41-G4
1-A51-B51-C51-D51-E51-F51-G5
1-A61-B61-C61-D61-E61-F61-G6
1-A71-B71-C71-D71-E71-F71-G7
1-A81-B81-C81-D81-E81-F81-G8
    1-C9        

<転記元ファイル2つめ>
test2.xlsの、「項目一覧」シート
2-A12-B12-C12-D12-E12-F12-G1
2-A22-B22-C22-D22-E22-F22-G2
2-A32-B32-C32-D32-E32-F32-G3
2-A42-B42-C42-D42-E42-F42-G4
2-A52-B52-C52-D52-E52-F52-G5
2-A62-B62-C62-D62-E62-F62-G6
2-A72-B72-C72-D72-E72-F72-G7
2-A82-B82-C82-D82-E82-F82-G8
    2-C9        

<集約結果>
xxxx.xlsのoutシート
1-B11-B21-A41-B41-C41-D41-E41-F41-G4
1-B11-B21-A51-B51-C51-D51-E51-F51-G5
1-B11-B21-A61-B61-C61-D61-E61-F61-G6
1-B11-B21-A71-B71-C71-D71-E71-F71-G7
1-B11-B21-A81-B81-C81-D81-E81-F81-G8
1-B11-B2    1-C9        
2-B12-B22-A42-B42-C42-D42-E42-F42-G4
2-B12-B22-A52-B52-C52-D52-E52-F52-G5
2-B12-B22-A62-B62-C62-D62-E62-F62-G6
2-B12-B22-A72-B72-C72-D72-E72-F72-G7
2-B12-B22-A82-B82-C82-D82-E82-F82-G8
2-B12-B2    2-C9        

<マクロ>
Sub 複数シート値を1シート集約()

    Application.ScreenUpdating = False

    Dim myReadBook_Obj As Workbook
    Dim myReadSheet_Obj As Worksheet
    
    Dim myWriteBook_Obj As Workbook
    Dim myWriteSheet_Obj As Worksheet

    'Set myWriteBook_Obj = ThisWorkbook
    'myWriteBook_Path = ThisWorkbook.Path
    
    myReadBook_Path = ThisWorkbook.Path
    myReadBook_Name = Dir(myReadBook_Path & "\test*.xls") '★転記元ファイル名。
    myReadSheet_Name = "項目一覧"                       '★転記元シート名。
    myRead_TargetCol_forLastRow = 3                    '★転記元の表の中で、一番行数の多い列番号。
    myReadStartRow = 4                                  '★転記元シートの、読み込み開始行番号。
    
    myWriteStartRow = 1                                 '★転記先シートの、出力開始行番号。
    Set myWriteSheet_Obj = ThisWorkbook.Sheets("out")       '★転記先シート名称を指定。

    myWriteRow = myWriteStartRow
    Do Until myReadBook_Name = Empty

        If myReadBook_Name <> ThisWorkbook.Name Then    '転記元ファイル名と、転記先ファイル名が一致していない場合のみ以下実施。

            Set myReadBook_Obj = Workbooks.Open(myReadBook_Path & "\" & myReadBook_Name)   '転記元ファイルオープン

            Set myReadSheet_Obj = myReadBook_Obj.Sheets(myReadSheet_Name)                      '転記元シートオープン

            myReadRow = myReadStartRow

            
            Do
                If myReadSheet_Obj.Cells(myReadRow, myRead_TargetCol_forLastRow).Value = "" Then    '転記するデータが無くなったらループを抜ける。
                    Exit Do
                End If


                myWriteSheet_Obj.Cells(myWriteRow, 1).Value = myReadSheet_Obj.Cells(1, 2).Value         'タイトル転記(転記先のA列に、転記元のB1セル値を転記)。
                myWriteSheet_Obj.Cells(myWriteRow, 2).Value = myReadSheet_Obj.Cells(2, 2).Value         'サブタイトル転記(転記先のB列に、転記元のB2セル値を転記)。

                myWriteSheet_Obj.Cells(myWriteRow, 3).Value = myReadSheet_Obj.Cells(myReadRow, 1).Value '表の値を転記。
                myWriteSheet_Obj.Cells(myWriteRow, 4).Value = myReadSheet_Obj.Cells(myReadRow, 2).Value '表の値を転記。
                myWriteSheet_Obj.Cells(myWriteRow, 5).Value = myReadSheet_Obj.Cells(myReadRow, 3).Value '表の値を転記。
                myWriteSheet_Obj.Cells(myWriteRow, 6).Value = myReadSheet_Obj.Cells(myReadRow, 4).Value '表の値を転記。
                myWriteSheet_Obj.Cells(myWriteRow, 7).Value = myReadSheet_Obj.Cells(myReadRow, 5).Value '表の値を転記。
                myWriteSheet_Obj.Cells(myWriteRow, 8).Value = myReadSheet_Obj.Cells(myReadRow, 6).Value '表の値を転記。
                myWriteSheet_Obj.Cells(myWriteRow, 9).Value = myReadSheet_Obj.Cells(myReadRow, 7).Value '表の値を転記。

                myReadRow = myReadRow + 1
                myWriteRow = myWriteRow + 1
            Loop
            myReadBook_Obj.Close                    '転記元ファイルクローズ。
            myReadBook_Count = myReadBook_Count + 1 '転記元ファイル数をカウントアップ。

        End If

        myReadBook_Name = Dir

    Loop
    
    Application.ScreenUpdating = True
    MsgBox myReadBook_Count & "ファイルコピー完了"
    


End Sub

コメントをかく


「http://」を含む投稿は禁止されています。

利用規約をご確認のうえご記入下さい

▼当HP内検索▼

▼メインメニュー▼



管理者用リンク
書籍(技術書)
・利用ソフト一覧
・Ethereal/Wireshark

転送速度




・powershell

・VBA










・Microsoft SQLserver








●CentOS6.9


▼動画サーバ関係

MP3について
DVDからのMP3変換について?
DVDからの動画変換について



▼自転車関係
・Panasonic CRAZY BOY

▼自動車関係
・SUZUKI エブリワゴンDA62W


▼Linux/Unix関係
・Linux基礎(パッケージ)
・Linux基礎(システム構成)
・Linux(Debian)基本コマンド
・Linuxコマンド(テキスト処理)
・Linuxコマンド(未整理)
・Linuxコマンド(ネットワーク系)
・FedoraCore OS メモ
・Debian Linux OS メモ
・Vine Linux OS メモ
・xPUD メモ

・CentOS6.4(minimal)


・solaris9 メモ
・solaris10 メモ

▼CCNA関係


▼ノートPC関連

液晶パネル

Fujitsu FMV-820MT
・Compaq Evo Notebook N110
・Panasonic Let's note CF-S51R
・Toshiba Dynabook Satellite 1800


▼デスクトップPC関連
・AOpen AX3S Pro-U
・ASUS CUSL2
・ASUS CUSL2-M


▼携帯電話
・NTT DoCoMo FOMA M1000
・FOMA P704iμ


▼モデム関連
▼ADSLモデム
・NTT ADSLモデム-NV
・NEC PA-WD605CV
・NEC PA-WD701CV
▼アナログモデム
・GVC F-1156IV/R9

▼ルータ関連
▼ルータ
・OMRON MR504DV
・FON La Fonera FON2100E
・Cisco Cisco2620
・Cisco4500M
・Cisco1601
  Cisco1603-R
  Cisco1605

・Cisco 共通メモ

・BUFFALO BLR3-TX4L
・I・O DATA NP-BBR
・NEC PA-WB7000/B (AtermWB7000H)
・マイクロ総研 NetGenesis OPT
・Persol PBR001

・YAMAHA NetVolante RTA54i
・FUJITSU NetVehicle-I

▼イーサネットコンバータ関連
・LINKSYS WET11

▼TA関連
・NEC AtermIT60D1L(S)

▼ハブ関連
・Cisco Catalyst 2924-XL-EN
・AlliedTelesis CentreCOM8216XL2
・BUFFALO LSW10/100-8
・corega FSW-5PM
・corega HUB-5PM
・CONTEC RT-1216S

▼NIC関連
・BUFFALO WLI-U2-SG54HP
・PLANEX GW-NS54GMX
・NTT-ME MN SS-LAN CARD 11 HQ

▼プリンタサーバ関連
・corega Pserver
・I・O DATA PLANT ET-FPS1E

▼デジカメ関連
・MINOLTA DiMAGE F100

▼携帯電話ケーブル関連
・BUFFALO IGM-UPDC
・OMRON ME64KTID
・OMRON ME96KTI
・SOURCENEXT SUS-USB-02 REV.1
・UP12 USB-PDC Converter
・DAISO D106

▼その他PC周辺機器
●キーボード
・Bluetoothキーボード BK3001BA
●ハンディターミナル
・ENSO BHT-6500
●ダウンスキャンコンバータ
・SC-TVEX
●CD-ROMドライブ
・NEC CD-2800D
・BUFFALO CDN-D24EX
・BUFFALO DVM-RDM16IU2
●MOドライブ
・ELECOM LMO-230-S
・FUJITSU MCF3064SS
・FUJITSU SMB-640WL2
●スピーカー
・Justy JSP-10W
●MP3プレーヤ
・SanDisk sansa e130
・NHJ V@mp VP-415
●インタフェースカード
・玄人志向 USB2.0+1394a-CB
・nbj IDE-3525
・Notebook Power Sharing
●ACアダプタ
・Universal AC Adaptor
●マウス
・Logitec Marble Mouse
・needs progres TN-30RFMOSG
●タブレット
・WACOM FAVO(ET-0405-U)
●その他
・IDEAL ME-320X(ME-320U2F)
・KY-05046S-12-H
・LifeView USB CapView
・ハードウェア(その他)
●シリアルレベルコンバータ
・シリアルレベルコンバータ


▼Windows系メモ
・DOS起動ディスク
・Microsoft OS メモ
・Microsoft 系ソフト メモ
・その他 ソフトウェアメモ
・Network Notepad
・Packet Tracerメモ
・パノラマ写真作成ソフト
・トラブル対処履歴


▼プログラミング関連
・言語比較
・VBS
・卒研事前メモ
・卒研メモ
・Windowsプログラミング
・JANコード・ISBNコード相互変換
●C言語
・文字列
・ファイル操作
●アルゴリズム
・再帰アルゴリズム
●JAVA
・Javaプログラミング
●その他
・初心者プログラミング
・ソフトウェア未整理メモ



▼家電関連
●テレビ
・SHARP AQUOS LC-20D10
・FUNAI TV-14CP
・BLUEDOT BTV-900K
・AKART AK-FTV913
・REAL LIFE JAPAN IQ-191LEDTV
AQUOS DZ3シリーズのDLNA機能
Viera V1シリーズのDLNA機能
●プロジェクタ
・crenova XPE470
●ビデオ
・FUNAI TV-14CP
●HDD&DVDレコーダ
・Toshiba RD-XS46
・NEC PK-AX10
●DVDプレーヤー
・GREEN HOUSER GH-PDV9AT
・情熱価格 DVDJ-DQ03
●メディアプレーヤー
・MINI HD MEDIA BOX 1080P
・1080P FULL HD Media Player
・1080P HD Media Player Mini 1080
・HD media player

●チューナー
・COMTEC DTW700
・HUMAX CI-S1

●アンテナ
・ADDZEST ZCP107
・マルハマ AGS-590

●ヘッドマウントディスプレイ
・VIRTUAL i/O i-glasses
●電動歯ブラシ
・ブラウン電動歯ブラシ
●電話機
・SHARP DA-C5-B
●コードレス電動ドリル、ドライバ
・BLACK&DECKER CSD300T
・RELIEF 30946?

▼カーナビ関係
Panasonic CN-GP510VD
Panasonic CN-G1100VD
▼カーステレオ関係
Kenwood U585SD

▼おもちゃ関連
●ラジコン
・ラジコンのプロポ改造


▼カー用品関連
●インダッシュTV
・ADDZEST TVS6250


▼DIY関連
・懸垂スタンド
・蓄光塗料


▼電子工作関係
・コネクタピンアサイン
・LANケーブルをAVケーブル化
・LANケーブルをRGBケーブル化
・地上デジタル放送アンテナ
・電子工作 メモ
・乾電池を充電


▼デザイン関連
●腕時計
・腕時計


▼その他

・HP製作関連メモ
・アイデアメモ

・コラム・メモ
・趣味・興味


・ToDo
・ネットインフラ?


▼資格・履歴書・マナー
・資格取得メモ
・工事担任者対策メモ
・履歴書・職務経歴書
・答辞


▼修学旅行 フランス(パリ)


▼掲示板
●掲示板
 意見・苦情・質問用に仮設置。

▼フリーエリア▼

▼おしらせ▼

管理人/副管理人のみ編集できます