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.「操作」シートの右にまとめたシートが作成される
└値・書式・コメントがコピーされる（関数等はコピーされない）
└Ａ列にコピー元のファイル名が記入される
＊.このブックから「操作」以外のシートを一気に削除したい場合は「他シートを削除」ボタンを押す
