人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

質問です。
エクセルで2行目から
現在のデータ
A列の文字データの行数にあわせて

追加したいデータ
B列に3文字 あああ
C列に2文字 いい
D列に数字 1234
E列に2文字 うう
を2行目から約2万行を一括で表示する。

フォルダー内に同じファイルが複数約50ファイル位あるので
マクロまたは関数で一度に一括できる方法を教えてください。


●質問者: inosisi
●カテゴリ:コンピュータ インターネット
✍キーワード:あああ エクセル データ ファイル フォルダー
○ 状態 :終了
└ 回答数 : 5/5件

▽最新の回答へ

1 ● SALINGER
●20ポイント ベストアンサー

ようはA列だけ入っているExcelのシートにB、C、D、E列に特定の値を追加するということでしょうか。

その場合、追加するシートは最初のシートになりますでしょうか。

最初のシートで作成しましたので、全てのシートの場合は修正します。


コードを実行するとフォルダ選択ダイアログが出ますので、ファイルのあるフォルダを選択すれば全てのファイルに追加します。

コード中の

stRow=2

は2行目からの意味です。

また、B列から追加するキーワードは

h = Array("ゲスト", "男性", "1800", "不明")

この部分を変更すれば変わります。


意図した動作と違う場合は変更しますので教えてください。


Sub Macro()
  '開始行を設定
 Const stRow As Integer = 2
 
 Dim h As Variant
 Dim FSO As Object
 Dim fldPath As String
 Dim fil As Object
 Dim wb As Workbook
 Dim lastRow As Long
 Dim i As Long
 Dim j As Integer
 
  'B列から追加する項目を設定
 h = Array("ゲスト", "男性", "1800", "不明")
 
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = True Then
 fldPath = .SelectedItems(1)
 Else
 Exit Sub
 End If
 End With
 
 Set FSO = CreateObject("Scripting.FileSystemObject")

 For Each fil In FSO.GetFolder(fldPath).Files
 If LCase(FSO.GetExtensionName(fil)) = "xls" Or _
 LCase(FSO.GetExtensionName(fil)) = "xlsx" Then
 Set wb = Nothing
 On Error Resume Next
 Set wb = Workbooks.Open(fil.Path)
 On Error GoTo 0
 
 If Not wb Is Nothing Then
 With wb.Worksheets(1)
 lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
 
 For i = stRow To lastRow
 For j = 0 To UBound(h)
 .Cells(i, j + 2).Value = h(j)
 Next j
 Next i
 End With
 
 wb.Save
 wb.Close
 End If
 End If
 Next
 
 Set FSO = Nothing
End Sub
◎質問者からの返答

ありがとうございます。

「新しいフォルダ」という名前のフォルダにエクセルでA列にデータがはいったサンプル4個作ってそのうちの1個のファイルからマクロを実実行しました。

フォルダ名を聞いてきましたがフォルダを選択できません

やりかたが間違っていますか?


2 ● SALINGER
●20ポイント

速度的に無駄な部分があったので修正しました。

A列はブック毎に任意のデータが入っていると解釈しています。

もしブック毎のA列が同じならば1つ作って後はブックを複製する方が早いです。

それと、マクロを実行するファイルはデータフォルダの中でも良いように変更しました。

>追加したい項目は固定ですが変更可能な作りが良いです

最初の回答のように変更できるように作っています。

実行速度は私の環境では5万行20ファイルで一瞬です。


Sub Macro()
 Application.ScreenUpdating = False
  '開始行を設定
 Const stRow As Integer = 2
 
 Dim h As Variant
 Dim FSO As Object
 Dim fldPath As String
 Dim fil As Object
 Dim wb As Workbook
 Dim lastRow As Long
 Dim i As Long
 Dim j As Integer
 
  'B列から追加する項目を設定
 h = Array("ゲスト", "男性", "1800", "不明")
 
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = True Then
 fldPath = .SelectedItems(1)
 Else
 Exit Sub
 End If
 End With
 
 Set FSO = CreateObject("Scripting.FileSystemObject")

 For Each fil In FSO.GetFolder(fldPath).Files
 If LCase(FSO.GetExtensionName(fil)) = "xls" Or _
 LCase(FSO.GetExtensionName(fil)) = "xlsx" Then
 Set wb = Nothing
 If fil.Name = ThisWorkbook.Name Then
 Set wb = ThisWorkbook
 Else
 On Error Resume Next
 Set wb = Workbooks.Open(fil.Path)
 On Error GoTo 0
 End If
 
 If Not wb Is Nothing Then
 With wb.Worksheets(1)
 lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
 
 For j = 0 To UBound(h)
 .Range(.Cells(stRow, j + 2), .Cells(lastRow, j + 2)).Value = h(j)
 Next j
 End With
 
 If wb.Name <> ThisWorkbook.Name Then
 wb.Save
 wb.Close
 End If
 End If
 End If
 Next
 
 Set FSO = Nothing
 Application.ScreenUpdating = True
End Sub
◎質問者からの返答

ありがとうございます。

上手く行きました。

私の拡張子の間違いでした。CSVでやっていました。

もしCSVの場合はXLSとXLSXをCSVに変更すればよいのでしょうか

CSVも含めてできるように修正していただければたすかります

前回より早くなっています。

実際のデータで明日もう一度やってみます。


3 ● きゃづみぃ
●20ポイント

少しでも 速くならないか 工夫してみました。

Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。
p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "xls")
Call jikkou(p, "csv")



End Sub

Sub jikkou(p As String, s As String)
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
 Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
 
  '処理対象は 1番目のシートのみ。
 b = w.Sheets(1).Range("A2").End(xlDown).Row
 
  '追加したい項目を セット
  'B列   C列  D列 E列
  'ゲスト 男性  1800 不明
 w.Sheets(1).Range("B2") = "ゲスト"
 w.Sheets(1).Range("C2") = "男性"
 w.Sheets(1).Range("D2") = "1800"
 w.Sheets(1).Range("E2") = "不明"
 
 w.Sheets(1).Range("B2:E2").Copy (w.Sheets(1).Range(w.Sheets(1).Cells(3, "B"), w.Sheets(1).Cells(b, "E")))
 
 Application.DisplayAlerts = False
 w.Save
 w.Close
 
 
 f = Dir
Loop


End Sub
◎質問者からの返答

ありがとうございます。

下記の最初の設定がわからないのですが

マクロの記述するファイルとそのフォルダの関係

実行するデータとそのソルダの関係

'対象フォルダを指定してください。

'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

の意味

すみません教えてください。


Dim p As String

'対象フォルダを指定してください。

'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。

Call jikkou(p, "xls")

Call jikkou(p, "csv")


4 ● きゃづみぃ
●20ポイント

B列に何か入っていたら、C列から というようにしてみました。

開始する行数は

開始行 = 1 '開始の行をセットします。

を 変更すれば いいようにしました。



Sub main()
Dim p As String
'対象フォルダを指定してください。
'このフォルダに この実行用のブックは 入れないでください。

p = "C:\test\"

'処理対象となる拡張子を指定して 呼び出します。
Call jikkou(p, "xls")
Call jikkou(p, "csv")

End Sub



Sub jikkou(p As String, s As String)
f = Dir(p & "*." & s, vbNormal)

Do While f <> ""
 Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=False)
 
 開始列 = 2  '開始の列をセットします。 2はB列です。3はC列です。
 開始行 = 1  '開始の行をセットします。
 
 
 With w.Sheets(1)
  '処理対象は 1番目のシートのみ。
 b = .Cells(開始行, "A").End(xlDown).Row
 
 
 If .Cells(開始行, "B").End(xlDown).Row < b Then
  'B列に何か入ってる行があれば 開始する列を C列からにする。
 開始列 = 開始列 + 1
 End If
 
 処理列 = 開始列
 
  '追加したい項目を セット
  'B列   C列  D列 E列
  'ゲスト 男性  1800 不明
 .Cells(開始行, 処理列) = "ゲスト"
 処理列 = 処理列 + 1
 .Cells(開始行, 処理列) = "男性"
 処理列 = 処理列 + 1
 .Cells(開始行, 処理列) = "1800"
 処理列 = 処理列 + 1
 .Cells(開始行, 処理列) = "不明"
 
 
 .Range(.Cells(開始行, 開始列), .Cells(開始行, 処理列)).Copy (.Range(.Cells(開始行 + 1, 開始列), .Cells(b, 処理列)))
 
 
 End With
 
 Application.DisplayAlerts = False
 w.Save
 w.Close
 
 
 f = Dir
Loop


End Sub

5 ● SALINGER
●20ポイント

ファイル毎に決まっているならば各行のチェックをする必要がないので実行速度を落とさないでできます。

修正する部分はそんなにありませんでした。

A列に男性、女性が入っているパターン2の場合はあらかじめA列を削除して追加をするようにしました。


Sub Macro()
 Application.ScreenUpdating = False
  '開始行を設定
 Const stRow As Integer = 2
 
 Dim h As Variant
 Dim FSO As Object
 Dim fldPath As String
 Dim fil As Object
 Dim wb As Workbook
 Dim lastRow As Long
 Dim i As Long
 Dim j As Integer
 
  'B列から追加する項目を設定
 h = Array("ゲスト", "男性", "1800", "不明")
 
 With Application.FileDialog(msoFileDialogFolderPicker)
 If .Show = True Then
 fldPath = .SelectedItems(1)
 Else
 Exit Sub
 End If
 End With
 
 Set FSO = CreateObject("Scripting.FileSystemObject")

 For Each fil In FSO.GetFolder(fldPath).Files
 If LCase(FSO.getextensionname(fil)) = "xls" Or _
 LCase(FSO.getextensionname(fil)) = "xlsx" Or _
 LCase(FSO.getextensionname(fil)) = "csv" Then
 Set wb = Nothing
 If fil.Name = ThisWorkbook.Name Then
 Set wb = ThisWorkbook
 Else
 On Error Resume Next
 Set wb = Workbooks.Open(fil.Path)
 On Error GoTo 0
 End If
 
 If Not wb Is Nothing Then
 With wb.Worksheets(1)
 lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
 
 If .Cells(stRow, "A").Value = "男性" Or _
 .Cells(stRow, "A").Value = "女性" Then
 Columns(1).Delete
 End If
 
 For j = 0 To UBound(h)
 .Range(.Cells(stRow, j + 2), .Cells(lastRow, j + 2)).Value = h(j)
 Next j
 End With
 
 If wb.Name <> ThisWorkbook.Name Then
 Application.DisplayAlerts = False
 wb.Save
 wb.Close
 Application.DisplayAlerts = True
 End If
 End If
 End If
 Next
 
 Set FSO = Nothing
 Application.ScreenUpdating = True
End Sub
◎質問者からの返答

お手数掛けます。

今試したらA列に男性B列にアドレスの場合

A列に男性が残ってB列のアドレスが削除されて

B列ゲストC列男性D列1800E列不明となってしまいました。

検証をおねがいします。

よろしくお願いします。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ