workbookシート
Private Sub workbook_open()
newbar
ThisWorkbook.IsAddin = False
sttingkey
ThisWorkbook.IsAddin = True
ThisWorkbook.Saved = True
End Sub
モジュール
Sub newbar()
'CommandBars("Kin").Delete
Application.CommandBars.Add Name:="Kin", temporary:=True
Dim newcombar As CommandBar
Dim Mene As CommandBarControl
Dim button As CommandBarButton
Set newcombar = Application.CommandBars("Kin")
newcombar.Visible = True
newcombar.Position = msoBarLeft
'コンポネス１
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "転換"
.OnAction = "heightConvert"
.Style = msoButtonIconAndCaption
End With
'コンポネス２
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "共通ヘッダー"
.OnAction = "commonHead"
.Style = msoButtonIconAndCaption
End With
'コンポネス３
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "WHERE"
.OnAction = "test"
.Style = msoButtonIconAndCaption
End With
'コンポネス４
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "フォカス"
.OnAction = "doFocus"
.Style = msoButtonIconAndCaption
End With
'コンポネス６
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "セール結合"
.OnAction = "doMergeSail"
.Style = msoButtonIconAndCaption
End With
''コンポネス６
'With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
'.Width = 200
'.Caption = "セール結合"
'.OnAction = "doMergeSail"
'.style = msoButtonIconAndCaption
'End With
'
''コンポネス６
'With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
'.Width = 200
'.Caption = "セール結合"
'.OnAction = "doMergeSail"
'.style = msoButtonIconAndCaption
'End With
'コンポネス９
With newcombar.Controls.Add(Type:=msoControlButton, ID:=2)
.Width = 200
.Caption = "ファイル名変更"
.OnAction = "renFileName"
.Style = msoButtonIconAndCaption
End With
End Sub
Function converAddress(startRow As Long, startCol As Long, endRow As Long, endCol As Long)
Dim startPoint As Integer
Dim endPonint As Integer
Dim addressStr As String
Dim addressStrArr() As String
Dim maxColumn As Long
startPoint = ActiveCell.Column
endPonint = ActiveCell.Height
addressStr = Application.Selection.Address
addressStrArr = Strings.Split(addressStr, ":")
' チェック
If UBound(addressStrArr) = 0 Then
MsgBox "複数セルを選択してください。"
converAddress = 0
Exit Function
End If
startRow = Range(addressStrArr(0)).Row
startCol = Range(addressStrArr(0)).Column
endRow = Range(addressStrArr(1)).Row + 1
endCol = Range(addressStrArr(1)).Column
End Function
Sub heightConvert()
Dim startRow As Long
Dim startCol As Long
Dim endRow As Long
Dim endCol As Long
Dim hight As Integer
Dim targetStartRow As Long
Dim targetEndRow As Long
Dim dataarr
temp = converAddress(startRow, startCol, endRow, endCol)
hight = endRow - startRow
targetStartRow = endRow + 2
targetEndRow = endRow + 2 + hight
'チェック
If endCol - startCol + 1 > 9000 Then
MsgBox "選択列は100列超過。 "
Exit Sub
End If
Dim i As Long
Dim arr
For i = startCol To endCol
' 列の単位のセルを取得
arr = Range(Cells(startRow, i), Cells(endRow, i))
' 一列にマージ
Range(Cells(targetStartRow, startCol), Cells(targetEndRow, startCol)).Value = arr
targetStartRow = targetStartRow + hight
targetEndRow = targetEndRow + hight
Next
MsgBox "完了"
End Sub
Sub doFocus()
Dim sheetCount As Integer
Dim i As Integer
Dim hidenSheet As String
hidenSheet = ""
Dim hidenSheetFlg As Boolean
hidenSheetFlg = False
sheetCount = Sheets.Count
For i = 1 To sheetCount
If Sheets(i).Visible = 0 Then
hidenSheet = hidenSheet & Sheets(i).Name & vbCrLf
hidenSheetFlg = True
GoTo continue
End If
Sheets(i).Select
SelectRange (30)
continue:
Next
If 1 < sheetCount Then
Sheets(2).Select
Range("a1").Select
End If
If hidenSheetFlg Then
MsgBox hidenSheet
End If
End Sub
Function SelectRange(inpram As Integer) As String
On Error GoTo MyError
Range(Cells(inpram, 1), Cells(inpram, 1)).Select
If inpram = 1 Then
Exit Function
End If
MyError:
If inpram > 16 Then
Call SelectRange(inpram - 5)
Else
Call SelectRange(inpram - 1)
End If
End Function
Sub doMergeSail()
Dim startRow As Long
Dim startCol As Long
Dim endRow As Long
Dim endCol As Long
Dim hight As Integer
temp = converAddress(startRow, startCol, endRow, endCol)
If temp = 0 Then
Exit Sub
End If
hight = endRow - startRow
'チェック
If endCol - startCol + 1 > 9000 Then
MsgBox "選択列は100列超過。 "
Exit Sub
End If
Dim i As Long
Dim mergeStart As Long
Dim mergeEnd As Long
mergeStart = startRow
Application.DisplayAlerts = False
For i = startCol To endCol
If Cells(i, startCol) <> Cells(i + 1, startCol) Then
mergeEnd = i
Range(Cells(mergeStart, startCol), Cells(mergeStart, startCol)).Merge
Range(Cells(mergeStart, startCol), Cells(mergeStart, startCol)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLeverl = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLeverl = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLeverl = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
mergeStart = i + 1
End If
Next
MsgBox "完了"
End Sub
Function CONCATENATECSV(ran As Range) As String
CONCATENATECSV = CONCATENATEAREAALL(ran, 1)
End Function
Function CONCATENATESPACE(ran As Range) As String
CONCATENATESPACE = CONCATENATEAREAALL(ran, 2)
End Function
Function CONCATENATESTRBUFFERE(ran As Range) As String
CONCATENATESTRBUFFERE = CONCATENATEAREAALL(ran, 0)
End Function
Function CONCATENATEAREAALL(ran As Range, options As Integer) As String
Const QUOTATION_MARKS As String = """"
Const SPACE As String = " "
Const COMMA As String = ","
' 範囲選択する
Dim startPoint As Integer
Dim endPoint As Integer
Dim addressStr As String
Dim addressStrArr() As String
Dim maxColumn As Long
startPoint = ran.Column
endPoint = ran.Height
addressStr = ran.Address
addressStrArr = Strings.Split(addressStr, ":")
addressStr = Range(addressStrArr(0)).Column
' チェック
If UBound(addressStrArr) = 0 Then
CONCATENATEAREAALL = QUOTATION_MARKS & ran.Value & QUOTATION_MARKS
Exit Function
End If
Dim startRow As Long
Dim startCol As Long
Dim endRow As Long
Dim endCol As Long
Dim hight As Integer
Dim targetStartRow As Long
Dim targetEndRow As Long
Dim dataarr
Dim prefix As String
Dim d As String
startRow = Range(addressStrArr(0)).Row
startCol = Range(addressStrArr(0)).Column
endRow = Range(addressStrArr(1)).Row
endCol = Range(addressStrArr(1)).Column
Dim i As Long
Dim ret As String
If options = 0 Then
prefix = ""
suffix = ""
ElseIf options = 1 Then
prefix = QUOTATION_MARKS
suffix = COMMA & QUOTATION_MARKS
ElseIf options = 2 Then
prefix = ""
suffix = SPACE
End If
For J = startRow To endRow
For i = startCol To endCol
If i = startCol And J = startRow Then
ret = ret & prefix & Cells(J, i) & prefix
Else
ret = ret & suffix & Cells(J, i) & prefix
End If
Next
Next
CONCATENATEAREAALL = ret
End Function
Function UPPERlLEFT(Str As String)
Dim ret As String
ret = Strings.UCase(Strings.Mid(Str, 1, 1)) & Strings.Mid(Str, 2, Len(Str))
UPPERlLEFT = ret
End Function
Function LOWER1LEFT(Str As String)
Dim ret As String
ret = Strings.LCase(Strings.Mid(Str, 1, 1)) & Strings.Mid(Str, 2, Len(Str))
LOWER1LEFT = ret
End Function
Function DATCRTSRT(Str As String)
ret = """" & SelectUpcaps(Str) & "001" & """"
DATCRTSRT = ret
End Function
Function SelectUpcaps(Str As String)
Dim lenth As Long, T As String, S As String, firstflg As Boolean
firstflg = True
J = Len(Str)
For i = 1 To J
S = Mid(Str, i, 1)
If firstflg Then
If S Like "[a-z]" Or S Like "A-Z" Then
T = T & Strings.UCase(S)
End If
Else
If Asc(S) > 64 And Asc(S) < 91 Then
T = T & S
End If
End If
Next i
SelectUpcaps = T
End Function
Function CommandItems(ran As Range, Optional options = -1) As String
Const QUOTATION_MARKS As String = """"
Const SPACE As String = " "
Const COMMA As String = ","
' 範囲選択する
Dim startPoint As Integer
Dim endPo9int As Integer
Dim addressStr As String
Dim addressStrArr() As String
Dim maxColumn As Long
startPoint = ran.Column
endPoint = ran.Height
addressStr = ran.Address
addressStrArr = Strings.Split(addressStr, ":")
addressStr = Range(addressStrArr(0)).Column
' チェック
If UBound(addressStrArr) = 0 Then
CommandItems = QUOTATION_MARKS & ran.Value & QUOTATION_MARKS
Exit Function
End If
Dim startRow As Long
Dim startCol As Long
Dim endRow As Long
Dim endCol As Long
Dim hight As lnteger
Dim targetStartRow As Long
Dim targetEndRow As Long
Dim dataarr
Dim prefix As String
Dim d As String
startRow = Range(addressStrArr(0)).Row
startCol = Range(addressStrArr(0)).Column
endRow = Range(addressStrArr(1)).Row
endCol = Range(addressStrArr(1)).Column
Dim i As Long
Dim ret As String
Dim io As Integer
io = options
ret = vbCrLf
For J = startRow To endRow
If J = endRow Then
ret = ret & SetListItem(Cells(J, startCol), Cells(J, startCol + 1), io, True)
Else
ret = ret & SetListItem(Cells(J, startCol), Cells(J, startCol + 1), io, False)
End If
Next
CommandItems = ret
End Function
Function SetListItem(nameJp As String, nameEn As String, oprantion As Integer, endflg As Boolean)
Dim retStr As String
Dim commaffix As String
commaffix = COMMA
If endflg Then
commaffix = ""
End If
If oprantion = 1 Then
retStr = Comment & nameJp & vbCrLf & nameEn + commaffix & vbCrLf
Else
retStr = Comment & nameEn & vbCrLf & nameJp + commaffix & vbCrLf
End If
SetListItem = retStr
End Function
Sub renFileName()
Dim startRow As Long
Dim startCol As Long
Dim endRow As Long
Dim endCol As Long
Dim hight As Integer
Dim targetStartRow As Long
Dim targetEndRow As Long
Dim dataarr
temp = converAddress(startRow, startCol, endRow, endCol)
If temp = 0 Then
Exit Sub
End If
hight = endRow - startRow
targetStartRow = endRow + 2
targetEndRow = endRow + 2 + hight
'チェック
If endCol - startCol + 1 > 9000 Then
MsgBox "選択列は100列超過。 "
Exit Sub
End If
Dim i As Long
Dim oldNameArr
Dim newNameArr
Dim tempNameArr
oldNameArr = Application.Transpose(Range(Cells(startRow, startCol), Cells(endRow, startCol)))
tempNameArr = oldNameArr
newNameArr = Application.Transpose(Range(Cells(startRow, endCol), Cells(endRow, endCol)))
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim oldPathName As String
Dim newPathName As String
Dim tempPathName As String
Dim filePath As String
filePath = oldNameArr(1)
Dim InputBoxFlg As Boolean
If filePath = "" Or newNameArr(1) <> "" Then
filePath = InputBox("パスを入力してください。")
InputBoxFlg = True
Else
InputBoxFlg = False
End If
If filePath = "" Then
filePath = "1"
End If
If Mid(filePath, Len(filePath), 1) <> "\" Then
filePath = filePath & "\"
End If
If InputBoxFlg Then
oldPathName = filePath & oldNameArr(1)
tempPathName = filePath & "temp_" & oldNameArr(1)
tempNameArr(1) = tempName
If fso.FileExists(oldPathName) And oldPathName <> newPathName Then
Name oldPathName As tempPathName
End If
End If
For i = 2 To UBound(oldNameArr) - 1
oldPathName = filePath & oldNameArr(i)
tempPathName = filePath & "temp_" & oldNameArr(i)
tempNameArr(i) = tempPathName
If fso.FileExists(oldPathName) And oldPathName <> newPathName Then
Name oldPathName As tempPathName
Else
GoTo continue1
End If
continue1:
Next
If InputBoxFlg Then
newPathName = filePath & newNameArr(1)
tempPathName = tempNameArr(i)
If fso.FileExists(tempPathName) Then
End If
End If
For i = 2 To UBound(oldNameArr) - 1
newPathName = filePath & newNameArr(i)
tempPathName = tempNameArr(i)
If fso.FileExists(tempPathName) Then
Name tempPathName As newPathName
Else
GoTo continue2
End If
continue2:
Next
MsgBox "完了"
End Sub
Sub sttingkey()
Application.MacroOptions Macro:="heightConvert", HasshortcutKey:=True, ShortcutKey:="j"
Application.MacroOptions Macro:="doFocus", HasshortcutKey:=True, ShortcutKey:="m"
End Sub
1、打开Microsoft Excel 。
2、点击左上角文件，然后点开箭头所指的“选项”。
3、弹出excel选项的窗口后，下拉选择箭头所指的“加载项”。
4、在下面的“管理”中选择禁用项目，然后鼠标左击旁边的“转到”。
5、在弹出的“禁用”窗口中查看是否有被禁用的项目，如果有，选择启用。
