エクセル小僧：別のエクセルファイルから文字列をコピーするマクロ【コード編】
別のエクセルファイル（以下、ワークブックと呼ぶ）から、文字列を
コピーしてくるマクロのコピーボタンのマクロのコードを示します。ワークシート側の設定については、
http://blog.so-net.ne.jp/cheese999/2012-12-23
を参照して下さい。
【コード：コピーボタン】
コピーボタンから呼ばれるマクロは、『USCopyIP2』です。
01:Function UFDelSP1(Str1 As String, Mode1 As Integer) As String
02: ' 【機能】文字列からスペースを削除
03: ' 【引数】
04: ' Str1 : 文字列(例：" 10. 2. 1. 2")
05: ' Mode1 : モード
06: ' 2^0=1 : 半角スペースを削除
07: ' 2^1=1 : 全角スペースを削除
08: ' 【変数】
09: Dim DelChr1 As Variant ' 削除する文字
10: Dim Str2 As String ' 文字列
11: Dim myMode2(1) As Integer ' モード
12: Dim i As Integer ' 整数
13: ' 【コード】
14: DelChr1 = Array(" ", " ") ' 削除する文字
15: Str2 = Str1
16: For i = 0 To 1
17: If Int(Mode1 / (2 ^ i)) Mod 2 = 1 Then
18: Str2 = Replace(Str2, DelChr1(i), "") ' DelChr1(i)を削除
19: End If
20: Next i
21: UFDelSP1 = Str2
22:End Function
01:Function UFShtChk1(mySheet As Variant, Wb1 As Workbook) As Boolean
02: ' 【機能】シートが存在するか確認
03: ' 【引数】
04: ' mySheet : シート名
05: ' Wb1 : コピー元のエクセルファイル
06: ' 【変数】
07: Dim i As Integer ' 整数
08: ' 【コード】
09: UFShtChk1 = False
10: ' シート枚数分、繰り返す
11: For i = 1 To Wb1.Worksheets.Count
12: If Wb1.Worksheets(i).Name = mySheet Then
13: UFShtChk1 = True ' 見つかった！
14: Exit For
15: End If
16: Next
17:End Function
01:Function UFNameChk1(myName1 As Variant, Wb1 As Workbook) As Boolean
02: ' 【機能】ワークブックにその名前が存在するか確認
03: ' 【引数】
04: ' myName1 : 名前
05: ' Wb1 : ワークブック（エクセルファイル）
06: ' 【変数】
07: Dim oName As Name ' 名前（繰り返し用）
08: ' 【コード】
09: UFNameChk1 = False ' 名前は見つかっていない
10: For Each oName In Wb1.Names
11: If oName.Name = myName1 Then
12: UFNameChk1 = True ' 名前が見つかった！
13: Exit For
14: End If
15: Next oName
16:End Function
01:Function UFWbOpnChk1(FilePath1 As String) As Boolean
02: ' 【機能】ファイルが既に開かれているか確認
03: ' 【引数】
04: ' FilePath1 : ファイルのフルパス
05: ' 【変数】
06: Dim Wb As Workbook ' ワークブック
07: Dim FilePath2 As String ' 既に開いているファイルのフルパス
08: ' 【コード】
09: UFWbOpnChk1 = False
10: For Each Wb In Workbooks
11: FilePath2 = Wb.Path & "\" & Wb.Name
12: If FilePath1 = FilePath2 Then
13: UFWbOpnChk1 = True ' 既に開かれている
14: Exit For
15: End If
16: Next Wb
17:End Function
01:Sub USCopyIP2()
02: ' 【機能】IPアドレスをコピー
03: ' 【変数】
04: Dim myRange1 As Variant ' セル範囲(Range)
05: ' myRange1(0) : コピー元のエクセルファイル名のRange
06: ' myRange1(1) : コピー元のエクセルファイルのシート名のRange
07: ' myRange1(2) : コピー元のセル名のRange
08: ' myRange1(3) : ファイルパスの形式のRange
09: ' myRange1(4) : コピー先のシート名のRange
10: ' 【コード】
11: myRange1 = Array("file1", "sheet1", "cell1", "TypeFilePath", "sheet2")
12: ' MsgBox UBound(myRange1)
13: Call USCopyData1(myRange1, True)
14:End Sub
001:Sub USCopyData1(myRange1 As Variant, Mode1 As Boolean)
002: ' 【機能】ファイル間でデータをコピー
003: ' 【引数】
004: ' myRange1(0) : コピー元のエクセルファイル名のRange
005: ' myRange1(1) : コピー元のエクセルファイルのシート名のRange
006: ' myRange1(2) : コピー元のセル名のRange
007: ' myRange1(3) : ファイルパスの形式のRange
008: ' myRange1(4) : コピー先のシート名のRange
009: ' mode1 : 文字列からスペースを削除するか(True：する)
010: ' 【変数】
011: Dim Wb1(1) As Workbook ' エクセルファイル
012: ' Wb1(0) : コピー元(Wb1)
013: ' Wb1(1) : コピー先(ThisWorkbook)
014: Dim FilePath1 As String ' コピー元のエクセルファイルのパス
015: Dim myFile1 As String ' コピー元のエクセルファイル名
016: Dim mySheet1 As Variant ' エクセルファイルのシート名
017: ' mySheet1(0) : コピー元(Sheet2)
018: ' mySheet1(1) : コピー先(Sheet3)
019: Dim myCell1 As Variant ' コピー元/コピー先のセル名
020: Dim myStr1(1) As Variant ' コピーする文字列
021: ' myStr1(0) : コピー元(myStr1)
022: ' myStr1(1) : コピー先(myStr2)
023: Dim TypeFilePath1 As String ' ファイルパスの形式
024: Dim Ans1 As Integer ' 答え
025: Dim i, j, k As Integer ' 整数
026: ' 【コード】
027: On Error GoTo myError
028: If UFShtChk1(Range(myRange1(4)).Value, ThisWorkbook) = False Then
029: Ans1 = MsgBox("シートが見つかりません。" & vbCrLf & _
030: "ファイル名：" & ThisWorkbook.Name & vbCrLf & _
031: "シート名：" & Range(myRange1(4)).Value, vbOKOnly + vbExclamation)
032: ' マクロを抜ける
033: Exit Sub
034: End If
035: With ThisWorkbook.Sheets(Range(myRange1(4)).Value)
036: ' コピー元のエクセルファイル名
037: myFile1 = .Range(myRange1(0)).Value
038: ' エクセルファイルのシート名(コピー元, コピー先)
039: mySheet1 = Array(.Range(myRange1(1)).Value, _
040: .Range(myRange1(4)).Value)
041: ' コピー元/コピー先のセル名
042: myCell1 = Split(.Range(myRange1(2)).Value, ",")
043: ' ファイルパスの形式
044: TypeFilePath1 = .Range(myRange1(3)).Value
045: End With
046: ' コピー元のエクセルファイルのパスを持ってくる
047: Select Case TypeFilePath1
048: Case "ファイル名"
049: FilePath1 = ThisWorkbook.Path & "\" & myFile1
050: Case "フルパス"
051: FilePath1 = myFile1
052: Case Else
053: Ans1 = MsgBox("ファイルパスの形式が範囲外です。", vbOKOnly + vbExclamation)
054: Exit Sub
055: End Select
056: ' コピー元ファイルの存在を確認する
057: If Dir(FilePath1) = "" Then
058: Ans1 = MsgBox("コピー元ファイルが見つかりません。" & vbCrLf & _
059: "ファイル名：" & FilePath1, vbOKOnly + vbExclamation)
060: Exit Sub
061: End If
062: ' コピー元ファイルが既に開いているか確認する
063: If UFWbOpnChk1(FilePath1) = True Then
064: Ans1 = MsgBox("コピー元ファイルが既に開いています。" & vbCrLf & _
065: "ファイル名：" & FilePath1, vbOKOnly + vbExclamation)
066: Exit Sub
067: End If
068: ' スクリーン更新停止
069: Application.ScreenUpdating = False
070: ' コピー元ファイルを開く
071: Set Wb1(0) = Workbooks.Open(Filename:=FilePath1, ReadOnly:=True)
072: ' コピー先ファイル
073: Set Wb1(1) = ThisWorkbook
074: ' シートの存在を確認
075: For i = 0 To 1
076: If UFShtChk1(mySheet1(i), Wb1(i)) = False Then
077: Ans1 = MsgBox("シートが見つかりません。" & vbCrLf & _
078: "ファイル名：" & Wb1(i).Name & vbCrLf & _
079: "シート名：" & mySheet1(i), vbOKOnly + vbExclamation)
080: ' コピー元のエクセルファイルを閉じる。保存はしない。
081: Wb1(0).Close (False)
082: ' スクリーン更新再開
083: Application.ScreenUpdating = True
084: ' マクロを抜ける
085: Exit Sub
086: End If
087: Next i
088: ' セル名の数だけ、繰り返す
089: For i = 0 To UBound(myCell1)
090: ' j=0(コピー元） j=1(コピー先）
091: For j = 0 To 1
092: ' セル名を確認する
093: If UFNameChk1(myCell1(i), Wb1(j)) = False Then
094: Ans1 = MsgBox("名前が見つかりません。" & vbCrLf & _
095: "ファイル名：" & Wb1(j).Name & vbCrLf & _
096: "名前：" & myCell1(i), vbOKOnly + vbExclamation)
097: ' コピー元のエクセルファイルを閉じる。保存はしない。
098: Wb1(0).Close (False)
099: ' スクリーン更新再開
100: Application.ScreenUpdating = True
101: ' マクロを抜ける
102: Exit Sub
103: End If
104: Next j
105: Next i
106: ' セル名の数だけ、繰り返す
107: For i = 0 To UBound(myCell1)
108: ' j=0(コピー元） j=1(コピー先）
109: For j = 0 To 1
110: ' セル範囲(Range)をファイルごとにmyStr1変数にセットする
111: Set myStr1(j) = Wb1(j).Sheets(mySheet1(j)).Range(myCell1(i))
112: Next j
113: ' １セルごとにデータをコピー
114: For j = 1 To myStr1(0).Rows.Count
115: For k = 1 To myStr1(0).Columns.Count
116: If Mode1 = True Then
117: ' スペースを削除してコピー
118: myStr1(1).Cells(j, k).Value = UFDelSP1(myStr1(0).Cells(j, k).Value, 3)
119: Else
120: ' そのままコピー
121: myStr1(1).Cells(j, k).Value = myStr1(0).Cells(j, k).Value
122: End If
123: Next k
124: Next j
125: Next i
126: ' コピー元のエクセルファイルを閉じる。保存はしない。
127: Wb1(0).Close (False)
128: ' スクリーン更新再開
129: Application.ScreenUpdating = True
130: ' 完了メッセージ
131: Ans1 = MsgBox("コピーを完了しました。")
132: Exit Sub
133:myError:
134: ' エラー処理
135: Ans1 = MsgBox("エラーですよ。", vbOKOnly + vbExclamation)
136: ' コピー元のエクセルファイルを閉じる。保存はしない。
137: Wb1(0).Close (False)
138: ' スクリーン更新再開
139: Application.ScreenUpdating = True
130:End Sub
【コード：ファイル名ボタン】
コードは次回、掲載します。
類似コードとしては、
http://blog.so-net.ne.jp/cheese999/2012-09-24
が、あたります。
コピーしてくるマクロのコピーボタンのマクロのコードを示します。ワークシート側の設定については、
http://blog.so-net.ne.jp/cheese999/2012-12-23
を参照して下さい。
【コード：コピーボタン】
コピーボタンから呼ばれるマクロは、『USCopyIP2』です。
01:Function UFDelSP1(Str1 As String, Mode1 As Integer) As String
02: ' 【機能】文字列からスペースを削除
03: ' 【引数】
04: ' Str1 : 文字列(例：" 10. 2. 1. 2")
05: ' Mode1 : モード
06: ' 2^0=1 : 半角スペースを削除
07: ' 2^1=1 : 全角スペースを削除
08: ' 【変数】
09: Dim DelChr1 As Variant ' 削除する文字
10: Dim Str2 As String ' 文字列
11: Dim myMode2(1) As Integer ' モード
12: Dim i As Integer ' 整数
13: ' 【コード】
14: DelChr1 = Array(" ", " ") ' 削除する文字
15: Str2 = Str1
16: For i = 0 To 1
17: If Int(Mode1 / (2 ^ i)) Mod 2 = 1 Then
18: Str2 = Replace(Str2, DelChr1(i), "") ' DelChr1(i)を削除
19: End If
20: Next i
21: UFDelSP1 = Str2
22:End Function
01:Function UFShtChk1(mySheet As Variant, Wb1 As Workbook) As Boolean
02: ' 【機能】シートが存在するか確認
03: ' 【引数】
04: ' mySheet : シート名
05: ' Wb1 : コピー元のエクセルファイル
06: ' 【変数】
07: Dim i As Integer ' 整数
08: ' 【コード】
09: UFShtChk1 = False
10: ' シート枚数分、繰り返す
11: For i = 1 To Wb1.Worksheets.Count
12: If Wb1.Worksheets(i).Name = mySheet Then
13: UFShtChk1 = True ' 見つかった！
14: Exit For
15: End If
16: Next
17:End Function
01:Function UFNameChk1(myName1 As Variant, Wb1 As Workbook) As Boolean
02: ' 【機能】ワークブックにその名前が存在するか確認
03: ' 【引数】
04: ' myName1 : 名前
05: ' Wb1 : ワークブック（エクセルファイル）
06: ' 【変数】
07: Dim oName As Name ' 名前（繰り返し用）
08: ' 【コード】
09: UFNameChk1 = False ' 名前は見つかっていない
10: For Each oName In Wb1.Names
11: If oName.Name = myName1 Then
12: UFNameChk1 = True ' 名前が見つかった！
13: Exit For
14: End If
15: Next oName
16:End Function
01:Function UFWbOpnChk1(FilePath1 As String) As Boolean
02: ' 【機能】ファイルが既に開かれているか確認
03: ' 【引数】
04: ' FilePath1 : ファイルのフルパス
05: ' 【変数】
06: Dim Wb As Workbook ' ワークブック
07: Dim FilePath2 As String ' 既に開いているファイルのフルパス
08: ' 【コード】
09: UFWbOpnChk1 = False
10: For Each Wb In Workbooks
11: FilePath2 = Wb.Path & "\" & Wb.Name
12: If FilePath1 = FilePath2 Then
13: UFWbOpnChk1 = True ' 既に開かれている
14: Exit For
15: End If
16: Next Wb
17:End Function
01:Sub USCopyIP2()
02: ' 【機能】IPアドレスをコピー
03: ' 【変数】
04: Dim myRange1 As Variant ' セル範囲(Range)
05: ' myRange1(0) : コピー元のエクセルファイル名のRange
06: ' myRange1(1) : コピー元のエクセルファイルのシート名のRange
07: ' myRange1(2) : コピー元のセル名のRange
08: ' myRange1(3) : ファイルパスの形式のRange
09: ' myRange1(4) : コピー先のシート名のRange
10: ' 【コード】
11: myRange1 = Array("file1", "sheet1", "cell1", "TypeFilePath", "sheet2")
12: ' MsgBox UBound(myRange1)
13: Call USCopyData1(myRange1, True)
14:End Sub
001:Sub USCopyData1(myRange1 As Variant, Mode1 As Boolean)
002: ' 【機能】ファイル間でデータをコピー
003: ' 【引数】
004: ' myRange1(0) : コピー元のエクセルファイル名のRange
005: ' myRange1(1) : コピー元のエクセルファイルのシート名のRange
006: ' myRange1(2) : コピー元のセル名のRange
007: ' myRange1(3) : ファイルパスの形式のRange
008: ' myRange1(4) : コピー先のシート名のRange
009: ' mode1 : 文字列からスペースを削除するか(True：する)
010: ' 【変数】
011: Dim Wb1(1) As Workbook ' エクセルファイル
012: ' Wb1(0) : コピー元(Wb1)
013: ' Wb1(1) : コピー先(ThisWorkbook)
014: Dim FilePath1 As String ' コピー元のエクセルファイルのパス
015: Dim myFile1 As String ' コピー元のエクセルファイル名
016: Dim mySheet1 As Variant ' エクセルファイルのシート名
017: ' mySheet1(0) : コピー元(Sheet2)
018: ' mySheet1(1) : コピー先(Sheet3)
019: Dim myCell1 As Variant ' コピー元/コピー先のセル名
020: Dim myStr1(1) As Variant ' コピーする文字列
021: ' myStr1(0) : コピー元(myStr1)
022: ' myStr1(1) : コピー先(myStr2)
023: Dim TypeFilePath1 As String ' ファイルパスの形式
024: Dim Ans1 As Integer ' 答え
025: Dim i, j, k As Integer ' 整数
026: ' 【コード】
027: On Error GoTo myError
028: If UFShtChk1(Range(myRange1(4)).Value, ThisWorkbook) = False Then
029: Ans1 = MsgBox("シートが見つかりません。" & vbCrLf & _
030: "ファイル名：" & ThisWorkbook.Name & vbCrLf & _
031: "シート名：" & Range(myRange1(4)).Value, vbOKOnly + vbExclamation)
032: ' マクロを抜ける
033: Exit Sub
034: End If
035: With ThisWorkbook.Sheets(Range(myRange1(4)).Value)
036: ' コピー元のエクセルファイル名
037: myFile1 = .Range(myRange1(0)).Value
038: ' エクセルファイルのシート名(コピー元, コピー先)
039: mySheet1 = Array(.Range(myRange1(1)).Value, _
040: .Range(myRange1(4)).Value)
041: ' コピー元/コピー先のセル名
042: myCell1 = Split(.Range(myRange1(2)).Value, ",")
043: ' ファイルパスの形式
044: TypeFilePath1 = .Range(myRange1(3)).Value
045: End With
046: ' コピー元のエクセルファイルのパスを持ってくる
047: Select Case TypeFilePath1
048: Case "ファイル名"
049: FilePath1 = ThisWorkbook.Path & "\" & myFile1
050: Case "フルパス"
051: FilePath1 = myFile1
052: Case Else
053: Ans1 = MsgBox("ファイルパスの形式が範囲外です。", vbOKOnly + vbExclamation)
054: Exit Sub
055: End Select
056: ' コピー元ファイルの存在を確認する
057: If Dir(FilePath1) = "" Then
058: Ans1 = MsgBox("コピー元ファイルが見つかりません。" & vbCrLf & _
059: "ファイル名：" & FilePath1, vbOKOnly + vbExclamation)
060: Exit Sub
061: End If
062: ' コピー元ファイルが既に開いているか確認する
063: If UFWbOpnChk1(FilePath1) = True Then
064: Ans1 = MsgBox("コピー元ファイルが既に開いています。" & vbCrLf & _
065: "ファイル名：" & FilePath1, vbOKOnly + vbExclamation)
066: Exit Sub
067: End If
068: ' スクリーン更新停止
069: Application.ScreenUpdating = False
070: ' コピー元ファイルを開く
071: Set Wb1(0) = Workbooks.Open(Filename:=FilePath1, ReadOnly:=True)
072: ' コピー先ファイル
073: Set Wb1(1) = ThisWorkbook
074: ' シートの存在を確認
075: For i = 0 To 1
076: If UFShtChk1(mySheet1(i), Wb1(i)) = False Then
077: Ans1 = MsgBox("シートが見つかりません。" & vbCrLf & _
078: "ファイル名：" & Wb1(i).Name & vbCrLf & _
079: "シート名：" & mySheet1(i), vbOKOnly + vbExclamation)
080: ' コピー元のエクセルファイルを閉じる。保存はしない。
081: Wb1(0).Close (False)
082: ' スクリーン更新再開
083: Application.ScreenUpdating = True
084: ' マクロを抜ける
085: Exit Sub
086: End If
087: Next i
088: ' セル名の数だけ、繰り返す
089: For i = 0 To UBound(myCell1)
090: ' j=0(コピー元） j=1(コピー先）
091: For j = 0 To 1
092: ' セル名を確認する
093: If UFNameChk1(myCell1(i), Wb1(j)) = False Then
094: Ans1 = MsgBox("名前が見つかりません。" & vbCrLf & _
095: "ファイル名：" & Wb1(j).Name & vbCrLf & _
096: "名前：" & myCell1(i), vbOKOnly + vbExclamation)
097: ' コピー元のエクセルファイルを閉じる。保存はしない。
098: Wb1(0).Close (False)
099: ' スクリーン更新再開
100: Application.ScreenUpdating = True
101: ' マクロを抜ける
102: Exit Sub
103: End If
104: Next j
105: Next i
106: ' セル名の数だけ、繰り返す
107: For i = 0 To UBound(myCell1)
108: ' j=0(コピー元） j=1(コピー先）
109: For j = 0 To 1
110: ' セル範囲(Range)をファイルごとにmyStr1変数にセットする
111: Set myStr1(j) = Wb1(j).Sheets(mySheet1(j)).Range(myCell1(i))
112: Next j
113: ' １セルごとにデータをコピー
114: For j = 1 To myStr1(0).Rows.Count
115: For k = 1 To myStr1(0).Columns.Count
116: If Mode1 = True Then
117: ' スペースを削除してコピー
118: myStr1(1).Cells(j, k).Value = UFDelSP1(myStr1(0).Cells(j, k).Value, 3)
119: Else
120: ' そのままコピー
121: myStr1(1).Cells(j, k).Value = myStr1(0).Cells(j, k).Value
122: End If
123: Next k
124: Next j
125: Next i
126: ' コピー元のエクセルファイルを閉じる。保存はしない。
127: Wb1(0).Close (False)
128: ' スクリーン更新再開
129: Application.ScreenUpdating = True
130: ' 完了メッセージ
131: Ans1 = MsgBox("コピーを完了しました。")
132: Exit Sub
133:myError:
134: ' エラー処理
135: Ans1 = MsgBox("エラーですよ。", vbOKOnly + vbExclamation)
136: ' コピー元のエクセルファイルを閉じる。保存はしない。
137: Wb1(0).Close (False)
138: ' スクリーン更新再開
139: Application.ScreenUpdating = True
130:End Sub
【コード：ファイル名ボタン】
コードは次回、掲載します。
類似コードとしては、
http://blog.so-net.ne.jp/cheese999/2012-09-24
が、あたります。
nice! ありがとうございます。
(^_0)ノ
by cheese999 (2012-12-25 04:31)
Very Merry Heavy Metal Christmas～☆ (^0^)/
by haku (2012-12-25 09:57)
ご訪問＆コメントありがとうございます＾＾
楽しい年の瀬をお過ごし下さい（＾＾）/
by alba0101 (2012-12-25 11:08)
☆ ☆ ☆
☆ ☆ ☆ ☆
☆ ☆ ☆ ☆
☆ ☆ ☆
☆ ◯ ◯ ☆ ☆ ／⊃／⊃
ヽ￣＼ ヽ￣＼ ☆ ☆ （ ⊃| ⊃
／´￣｀ヽ / ヽ / ヽ ☆ ＼⊃ヽ⊃
/ (二二二)(二二二) ミ| |_| |
| 川 ﾟ∀ﾟ）（ ´∀｀） ／￣─彡⊂ ・ ＼
人 x|￣￣￣|⌒)⊃Ｃ)）)⊃C)∞∞∞∞∞∞∞∞/ 彡 ソﾟ
| ￣|_,) ) ⌒) ⌒) | | ＿ ＿彳〃〃〃ミ
|＿＿＿＿__|三三三三三三|＿ | / >> ＼ヽノ
☆ | |＿＿| |＿ノ ノ＿＿| |＿ノ ノ || // /||
// || //||
by モッズパンツ (2012-12-25 23:21)
みなさ～ん、
めり～・くり～すま～す！
(^_0)ノ
by cheese999 (2012-12-25 23:22)
誤記を訂正しました。
(^_0)ノ
by cheese999 (2012-12-28 22:57)