excelの表をtextile記法に変換
excelの表をそのまま貼りつけるだけでtextile記法に変換するページの作り方
1.↓のコードをコピーしてメモ帳に貼り付け
2.文字コードを「UTF-8」、ファイル名を「~.html」にして保存
3.作ったファイルをwebブラウザで開く
4.枠の中に変換したいセルをコピペして「変換」ボタンを押す
<!DOCTYPE html> <html> <head> <meta charset="utf-8"> </head> <body> <form action="#" id="form"> <textarea name="word" id="comment"></textarea> <input type="submit" value="変換"> </form> <div id="output"></div> <script> document.getElementById('form').onsubmit = function() { var search = document.getElementById('form').word.value; var search2 = search.replace(/\r?\n/g, '|<br>|'); var search3 = search2.replace(/\t/g, '|'); var search4 = '|' + search3 document.getElementById('output').innerHTML = search4; return false; }; </script> </body> </html>
複数ファイルから指定シート名のデータをまとめるマクロ
複数ファイルから指定シート名のデータをまとめるマクロ
↓excelファイルの画面
↓コード
Option Explicit Sub 削除() Dim ans As Integer ans = MsgBox("「" & ActiveSheet.Name & "」以外のシートを削除しますか?", vbOKCancel, "削除確認") If ans = vbCancel Then Exit Sub Dim targetSheet As Worksheet '繰り返し用 '警告メッセージを表示しない Application.DisplayAlerts = False '削除処理 For Each targetSheet In Worksheets If targetSheet.Name <> ActiveSheet.Name Then targetSheet.Delete End If Next '警告メッセージを表示 Application.DisplayAlerts = True End Sub Function シート存在チェック(strSheetName As String) Dim objWorksheet As Worksheet On Error GoTo NotExists Set objWorksheet = ActiveWorkbook.Sheets(strSheetName) シート存在チェック = True Exit Function NotExists: シート存在チェック = False End Function Function 値が入っているかチェック(nullSheet As Worksheet) On Error GoTo NoExists Dim wTarget As Range 'SpecialCellsで取得したセルの参照をワーク領域へ保存 Set wTarget = nullSheet.Cells.SpecialCells(xlCellTypeConstants) 値が入っているかチェック = True Exit Function NoExists: 値が入っているかチェック = False End Function Sub まとめる() Dim sFile As String Dim sWB As Workbook Dim dWS As Worksheet Dim dl_Dir As String Dim SOURCE_DIR As String Dim flg As Long Dim Maxrow As Long Dim lRow As Long 'データ最終行取得変数 Dim lCol As Long 'データ最終列取得変数 Dim lRow2 As Long 'データ最終行取得変数2 Dim sSheetName As String Dim dSheetName As String Dim TitleRows As String Dim j As Long Dim CworkS As Boolean 'Loopの終了判定(シート存在チェック) sSheetName = Cells(5, 4).Value TitleRows = Cells(8, 4).Value If sSheetName = "" Then MsgBox "シート名を入力してください" Exit Sub ElseIf TitleRows = "" Then MsgBox "見出し行の数を入力してください" Exit Sub End If Application.ScreenUpdating = False '更新非表示 Cells(2, 4).ClearContents 'ダイアログでフォルダ選択 With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択して下さい" If .Show = False Then Exit Sub dl_Dir = .SelectedItems(1) End With SOURCE_DIR = dl_Dir & "\" '指定したフォルダ内にあるブックのファイル取得 sFile = Dir(SOURCE_DIR & "*.xls*") 'フォルダ内にブックがなければ終了 If sFile = "" Then Exit Sub '集約用シートを作成 Worksheets.Add After:=Worksheets(1) Set dWS = Worksheets(2) dSheetName = sSheetName CworkS = シート存在チェック(dSheetName) j = 0 Do While CworkS '重複したworksheetがある場合、(1), (2), ...と連番をつけて, '更に重複が無いか調べてない場合はWorksheet名として適用する。 j = j + 1 '連番用の変数 'シート名の再設定 dSheetName = sSheetName & "(" & j & ")" CworkS = シート存在チェック(dSheetName) Loop dWS.Name = dSheetName flg = 0 Do Application.DisplayAlerts = False Set sWB = Workbooks.Open(Filename:=SOURCE_DIR & sFile, ReadOnly:=True) Application.DisplayAlerts = True '★アラートの表示状況により位置を変える If シート存在チェック(sSheetName) Then 'シート再表示 Sheets(sSheetName).Visible = True Sheets(sSheetName).Select If flg = 0 And TitleRows >= 1 Then '列見出しをコピー lCol = sWB.Worksheets(sSheetName).UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column sWB.Worksheets(sSheetName).Range(Cells(1, 1), Cells(TitleRows, lCol)).Copy dWS.Range("B1").PasteSpecial Paste:=xlPasteValues dWS.Range("B1").PasteSpecial Paste:=xlPasteFormats dWS.Range("B1").PasteSpecial Paste:=xlPasteComments Application.CutCopyMode = False End If sWB.Activate With Worksheets(sSheetName) lRow = .UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row lCol = .UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column 'シートのデータがTitleRows行以上の場合にコピー If lRow > TitleRows Then dWS.Activate If 値が入っているかチェック(dWS) = True Then lRow2 = dWS.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row + 1 Else lRow2 = 1 End If .Activate .Range(Cells(TitleRows + 1, 1), Cells(lRow, lCol)).Copy dWS.Cells(lRow2, 2).PasteSpecial Paste:=xlPasteValues dWS.Cells(lRow2, 2).PasteSpecial Paste:=xlPasteFormats dWS.Cells(lRow2, 2).PasteSpecial Paste:=xlPasteComments Application.CutCopyMode = False dWS.Activate Maxrow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row dWS.Range(Cells(lRow2, 1), Cells(Maxrow, 1)).Value = sWB.Name If flg Mod 2 = 0 Then Range(Cells(lRow2, 1), Cells(Maxrow, 1)).Interior.ColorIndex = 37 Else Range(Cells(lRow2, 1), Cells(Maxrow, 1)).Interior.ColorIndex = 36 End If End If End With End If 'コピー元ファイルを閉じる sWB.Close SaveChanges:=False '次のブックのファイル名を取得 sFile = Dir() flg = flg + 1 Loop While sFile <> "" ThisWorkbook.Sheets(1).Cells(2, 4) = dl_Dir If 値が入っているかチェック(dWS) = True Then MsgBox "「" & dSheetName & "」シートが作成されました" Else 'シート名のミスなどで該当データがなければシートを削除してメッセージを表示 Application.DisplayAlerts = False dWS.Delete Application.DisplayAlerts = True ThisWorkbook.Sheets(1).Activate MsgBox "「" & sSheetName & "」シートのデータが見つかりませんでした" & vbNewLine & "フォルダとシート名に間違いがないか確認してください" End If Application.ScreenUpdating = True '更新表示 End Sub
↓操作方法
0.まとめたいシートのあるexcelファイルだけを一つのフォルダに入れておく(フォルダの場所や名前は任意)
1.まとめたいシート名をD5に記入する
2.シートの見出し行の数をD8に記入する(全ファイルで共通する行の数)
3.「まとめる」ボタンを押し、1で作ったフォルダを選択する
4.「操作」シートの右にまとめたシートが作成される
└値・書式・コメントがコピーされる(関数等はコピーされない)
└A列にコピー元のファイル名が記入される
*.このブックから「操作」以外のシートを一気に削除したい場合は「他シートを削除」ボタンを押す