いれカエル(列順入れ替え)

アップするの忘れていました。

ソースコードを遅ればせながらアップします。

Option Explicit

Const SRC_ROW = 2
Const DST_ROW = 3
Const TOPCELL_S = "B10"
Const TOPCELL_D = "C10"
Const ST_ROW = 11

Sub Format_Henkan()

  Dim ws_c As Worksheet '現在のワークシート情報
  Dim ws_s As Worksheet 'source のワークシート
  Dim ws_d As Worksheet 'destination のワークシート

  '現在のシート(このいれカエルシートの事)
  Set ws_c = ActiveSheet

  'sourceワークシートを開く
  Set ws_s = Get_Worksheet(SRC_ROW, ws_c)

  'destinationワークシートを開く
  Set ws_d = Get_Worksheet(DST_ROW, ws_c)

  'FailProof Sourceワークシートと、Destinationワークシートが正しく選択されている事の確認
  If ws_s Is Nothing Or ws_d Is Nothing Then
    MsgBox ("ワークシートが正しく選択されていません。処理を中断します。")
    Exit Sub
  End If

  'Format変換の準備
  'source のワークシートから情報を取得
  Dim src_row_max As Long
  Dim src_col_max As Long
  Dim src_top_row As Long
  Dim src_left_col As Long
  src_top_row = ws_s.Range(ws_c.Range(TOPCELL_S)).Row             'データ先頭の行
  src_left_col = ws_s.Range(ws_c.Range(TOPCELL_S)).Column         'データ先頭の列
  src_row_max = ws_s.Cells(50000, src_left_col).End(xlUp).Row 'データが存在する最大行
  src_col_max = ws_s.Cells(src_top_row, 1000).End(xlToLeft).Column 'データが存在する最大列
  
  'Sorceワークシートでコピーするデータ数を取得(繰り返し回数)
  Dim row_area As Long
  row_area = src_row_max - src_top_row
  
  'destinationのワークシートから情報を取得
  Dim dst_top_row As Long
  Dim dst_left_col As Long
  dst_top_row = ws_d.Range(ws_c.Range(TOPCELL_D)).Row
  dst_left_col = ws_d.Range(ws_c.Range(TOPCELL_D)).Column
  
  '変換情報を使用して、情報変換
  Dim c_row As Long
  
  Dim s_col As String
  Dim d_col As String
  Dim pre_word As String
  Dim suf_word As String
  Dim I As Long
  
  'A11列以降、A列が空白になるまで繰り返し
  c_row = ST_ROW
  Do Until ws_c.Cells(c_row, 1) = ""
    'コピー元行、コピー先行の取得
    s_col = ws_c.Cells(c_row, 2)
    d_col = ws_c.Cells(c_row, 3)
    
    'コピー時に、追加する文字情報(prefix, suffix)を取得する
    pre_word = ws_c.Cells(c_row, 4)
    suf_word = ws_c.Cells(c_row, 5)
    
     'Rangeで複数セルを一括で処理すると、細かい調整ができなかった(もしかしたら実行時エラー?)
'    If pre_word = "" And suf_word = "" Then
'      ws_d.Range(ws_d.Cells(dst_top_row, d_col), ws_d.Cells(dst_top_row + row_area, d_col)).Value = _
'        ws_s.Range(ws_s.Cells(src_top_row, s_col), ws_s.Cells(src_row_max, s_col)).Value
'    Else

    '1つずつ処理する、pre_word + copyデータ + suf_wordとなるように
    For I = 0 To row_area
      ws_d.Cells(dst_top_row + I, d_col).Value = pre_word & ws_s.Cells(src_top_row + I, s_col).Value & suf_word
    Next I
'    End If
    
    '次のコピー行に移動する
    c_row = c_row + 1
    
  Loop
  
End Sub

Private Function Get_Worksheet(c_row As Long, ws_c As Worksheet) As Worksheet
  
  Dim open_type As String
  Dim tmp_ws As Worksheet
  
  '一番左の数字で判定する
  open_type = Left(ws_c.Cells(c_row, 2), 1)

  '1 すでに開いているWorkbookから選択させる場合
  If open_type = "1" Then
    
    '変数定義
    Dim disp_msg As String '表示メッセ格納用
    Dim wb As Variant 'temporaryのWorkbook格納用
    Dim ws As Variant 'temporaryのWorksheet格納用
    Dim cnt As Long   'workbook, worksheetの数計算用
    Dim wb_num As Long '選択するWorkbookの番号
    Dim ws_num As Long '選択するWorksheetの番号
    
    'Workbook名を1枚ずつ取得する
    cnt = 1
    For Each wb In Workbooks
      'メッセージとして、Workbookの番号と、名前をdisp_msgに格納する
      disp_msg = disp_msg & vbCrLf & cnt & ":" & wb.Name & ","
      cnt = cnt + 1
    Next wb
    
    'workbookの一覧から取得する
    wb_num = InputBox(disp_msg, "選択してください")
    
    'FailProof (変な入力をはじく)
    Do Until CInt(wb_num) > 0 And CInt(wb_num) < cnt
      wb_num = InputBox(disp_msg, "正しく選択してください")
    Loop
    
    'シートを選択する関数実行
    Set tmp_ws = Worksheet_Selection(Workbooks(wb_num))
    
  ElseIf open_type = "2" Then 'ファイル名を指定していた場合の処理
    
    '変数定義
    Dim wb_name As String 'Workbookの名前取得
    
    'F列からファイル名情報を取得
    wb_name = ws_c.Cells(c_row, 6)
    
    'ファイルの存在を確認し、ファイルが存在してたら処理を続行
    If Dir(wb_name) <> "" Then
      Workbooks.Open (wb_name)
      Set tmp_ws = Worksheet_Selection(Workbooks(Workbooks.Count))
    Else
      Set tmp_ws = Nothing
    End If
  
  ElseIf open_type = "3" Then 'フォルダ指定していた場合の処理
  
    '変数定義
    Dim open_filename As String
    
    'GetOpenFilename実行時のデフォルトフォルダを設定(ドライブが存在する場合などは未確認)
    ChDir ws_c.Cells(c_row, 6)
    
    'ファイル選択ダイアログ
    open_filename = Application.GetOpenFilename("*")
    
    'ファイルオープン
    Workbooks.Open (open_filename)
    
    Set tmp_ws = Worksheet_Selection(Workbooks(Workbooks.Count))
  
  Else 'プルダウンで設定しているのでないと思うが、、、
    Set tmp_ws = Nothing
    MsgBox "選択方法が設定されていません"
    Exit Function
  End If

  '戻り値を設定
  Set Get_Worksheet = tmp_ws

End Function

'複数のWorksheetから必要なWorksheetを選択させる
Private Function Worksheet_Selection(wb As Workbook) As Worksheet
  
  '変数宣言
  Dim disp_msg As String
  Dim cnt As Long
  Dim ws As Variant
  Dim ws_num As Long
  Dim tmp_ws As Worksheet
  
  'Worksheetが1枚しか存在していないときの処理
  If wb.Worksheets.Count = 1 Then
    Set tmp_ws = wb.Worksheets(1)
  
  'Worksheetが複数存在していないときの処理
  Else
    '変数の初期化
    disp_msg = ""
    cnt = 1
    
    'シート名を抽出
    For Each ws In wb.Worksheets
      disp_msg = disp_msg & vbCrLf & cnt & ":" & ws.Name & ","
      cnt = cnt + 1
    Next ws
    
    'ワークシートを選択させる
    ws_num = InputBox(disp_msg, "選択してください")
    'FailProof (変な入力をはじく)
    Do Until CInt(ws_num) > 0 And CInt(ws_num) < cnt
      ws_num = InputBox(disp_msg, "正しく選択してください")
    Loop
    
    Set tmp_ws = wb.Worksheets(ws_num)
  End If

  '戻り値を設定
  Set Worksheet_Selection = tmp_ws

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

Option Explicit

Const SRC_ROW = 2

Const DST_ROW = 3

Const TOPCELL_S = "B10"

Const TOPCELL_D = "C10"

Const ST_ROW = 11

Sub Format_Henkan()

Dim ws_c As Worksheet '現在のワークシート情報

Dim ws_s As Worksheet 'source のワークシート

Dim ws_d As Worksheet 'destination のワークシート

'現在のシート(このいれカエルシートの事)

Set ws_c = ActiveSheet

'sourceワークシートを開く

Set ws_s = Get_Worksheet(SRC_ROW, ws_c)

'destinationワークシートを開く

Set ws_d = Get_Worksheet(DST_ROW, ws_c)

'FailProof Sourceワークシートと、Destinationワークシートが正しく選択されている事の確認

If ws_s Is Nothing Or ws_d Is Nothing Then

MsgBox ("ワークシートが正しく選択されていません。処理を中断します。")

Exit Sub

End If

'Format変換の準備

'source のワークシートから情報を取得

Dim src_row_max As Long

Dim src_col_max As Long

Dim src_top_row As Long

Dim src_left_col As Long

src_top_row = ws_s.Range(ws_c.Range(TOPCELL_S)).Row 'データ先頭の行

src_left_col = ws_s.Range(ws_c.Range(TOPCELL_S)).Column 'データ先頭の列

src_row_max = ws_s.Cells(50000, src_left_col).End(xlUp).Row 'データが存在する最大行

src_col_max = ws_s.Cells(src_top_row, 1000).End(xlToLeft).Column 'データが存在する最大列

'Sorceワークシートでコピーするデータ数を取得(繰り返し回数)

Dim row_area As Long

row_area = src_row_max - src_top_row

'destinationのワークシートから情報を取得

Dim dst_top_row As Long

Dim dst_left_col As Long

dst_top_row = ws_d.Range(ws_c.Range(TOPCELL_D)).Row

dst_left_col = ws_d.Range(ws_c.Range(TOPCELL_D)).Column

'変換情報を使用して、情報変換

Dim c_row As Long

Dim s_col As String

Dim d_col As String

Dim pre_word As String

Dim suf_word As String

Dim I As Long

'A11列以降、A列が空白になるまで繰り返し

c_row = ST_ROW

Do Until ws_c.Cells(c_row, 1) = ""

'コピー元行、コピー先行の取得

s_col = ws_c.Cells(c_row, 2)

d_col = ws_c.Cells(c_row, 3)

'コピー時に、追加する文字情報(prefix, suffix)を取得する

pre_word = ws_c.Cells(c_row, 4)

suf_word = ws_c.Cells(c_row, 5)

'Rangeで複数セルを一括で処理すると、細かい調整ができなかった(もしかしたら実行時エラー?)

' If pre_word = "" And suf_word = "" Then

' ws_d.Range(ws_d.Cells(dst_top_row, d_col), ws_d.Cells(dst_top_row + row_area, d_col)).Value = _

' ws_s.Range(ws_s.Cells(src_top_row, s_col), ws_s.Cells(src_row_max, s_col)).Value

' Else

'1つずつ処理する、pre_word + copyデータ + suf_wordとなるように

For I = 0 To row_area

ws_d.Cells(dst_top_row + I, d_col).Value = pre_word & ws_s.Cells(src_top_row + I, s_col).Value & suf_word

Next I

' End If

'次のコピー行に移動する

c_row = c_row + 1

Loop

End Sub

Private Function Get_Worksheet(c_row As Long, ws_c As Worksheet) As Worksheet

Dim open_type As String

Dim tmp_ws As Worksheet

'一番左の数字で判定する

open_type = Left(ws_c.Cells(c_row, 2), 1)

'1 すでに開いているWorkbookから選択させる場合

If open_type = "1" Then

'変数定義

Dim disp_msg As String '表示メッセ格納用

Dim wb As Variant 'temporaryのWorkbook格納用

Dim ws As Variant 'temporaryのWorksheet格納用

Dim cnt As Long 'workbook, worksheetの数計算用

Dim wb_num As Long '選択するWorkbookの番号

Dim ws_num As Long '選択するWorksheetの番号

'Workbook名を1枚ずつ取得する

cnt = 1

For Each wb In Workbooks

'メッセージとして、Workbookの番号と、名前をdisp_msgに格納する

disp_msg = disp_msg & vbCrLf & cnt & ":" & wb.Name & ","

cnt = cnt + 1

Next wb

'workbookの一覧から取得する

wb_num = InputBox(disp_msg, "選択してください")

'FailProof (変な入力をはじく)

Do Until CInt(wb_num) > 0 And CInt(wb_num) < cnt

wb_num = InputBox(disp_msg, "正しく選択してください")

Loop

'シートを選択する関数実行

Set tmp_ws = Worksheet_Selection(Workbooks(wb_num))

ElseIf open_type = "2" Then 'ファイル名を指定していた場合の処理

'変数定義

Dim wb_name As String 'Workbookの名前取得

'F列からファイル名情報を取得

wb_name = ws_c.Cells(c_row, 6)

'ファイルの存在を確認し、ファイルが存在してたら処理を続行

If Dir(wb_name) <> "" Then

Workbooks.Open (wb_name)

Set tmp_ws = Worksheet_Selection(Workbooks(Workbooks.Count))

Else

Set tmp_ws = Nothing

End If

ElseIf open_type = "3" Then 'フォルダ指定していた場合の処理

'変数定義

Dim open_filename As String

'GetOpenFilename実行時のデフォルトフォルダを設定(ドライブが存在する場合などは未確認)

ChDir ws_c.Cells(c_row, 6)

'ファイル選択ダイアログ

open_filename = Application.GetOpenFilename("*")

'ファイルオープン

Workbooks.Open (open_filename)

Set tmp_ws = Worksheet_Selection(Workbooks(Workbooks.Count))

Else 'プルダウンで設定しているのでないと思うが、、、

Set tmp_ws = Nothing

MsgBox "選択方法が設定されていません"

Exit Function

End If

'戻り値を設定

Set Get_Worksheet = tmp_ws

End Function

'複数のWorksheetから必要なWorksheetを選択させる

Private Function Worksheet_Selection(wb As Workbook) As Worksheet

'変数宣言

Dim disp_msg As String

Dim cnt As Long

Dim ws As Variant

Dim ws_num As Long

Dim tmp_ws As Worksheet

'Worksheetが1枚しか存在していないときの処理

If wb.Worksheets.Count = 1 Then

Set tmp_ws = wb.Worksheets(1)

'Worksheetが複数存在していないときの処理

Else

'変数の初期化

disp_msg = ""

cnt = 1

'シート名を抽出

For Each ws In wb.Worksheets

disp_msg = disp_msg & vbCrLf & cnt & ":" & ws.Name & ","

cnt = cnt + 1

Next ws

'ワークシートを選択させる

ws_num = InputBox(disp_msg, "選択してください")

'FailProof (変な入力をはじく)

Do Until CInt(ws_num) > 0 And CInt(ws_num) < cnt

ws_num = InputBox(disp_msg, "正しく選択してください")

Loop

Set tmp_ws = wb.Worksheets(ws_num)

End If

'戻り値を設定

Set Worksheet_Selection = tmp_ws

End Function

MENU

VBA関連

VBA関連