質問です。

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

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

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

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2011/05/07 21:29:02
  • 終了:2011/05/10 19:42:49

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/08 09:55:47

ポイント20pt

ようは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
id:inosisi4141

ありがとうございます。

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

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

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

2011/05/08 16:51:01

その他の回答(4件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/08 09:55:47ここでベストアンサー

ポイント20pt

ようは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
id:inosisi4141

ありがとうございます。

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

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

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

2011/05/08 16:51:01
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/08 17:58:45

ポイント20pt

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

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
id:inosisi4141

ありがとうございます。

上手く行きました。

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

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

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

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

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

2011/05/08 19:47:52
id:taknt No.3

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/05/09 12:20:46

ポイント20pt

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

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
id:inosisi4141

ありがとうございます。

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

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

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

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

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

p = "C:\test\"

の意味

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


Dim p As String

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

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

p = "C:\test\"

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

Call jikkou(p, "xls")

Call jikkou(p, "csv")

2011/05/09 18:24:37
id:taknt No.4

きゃづみぃ回答回数13537ベストアンサー獲得回数11982011/05/10 12:01:45

ポイント20pt

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
id:SALINGER No.5

SALINGER回答回数3454ベストアンサー獲得回数9692011/05/10 15:25:14

ポイント20pt

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

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

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
id:inosisi4141

お手数掛けます。

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

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

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

検証をおねがいします。

よろしくお願いします。

2011/05/10 16:37:10
  • id:kanshizm
    具体例で示してもらった方が、回答はもらいやすいかもしれません。
    ちょっと、質問の意図がつかみかねるので。
  • id:taknt
    >A列の文字データの行数にあわせて

    ここらへんとか
  • id:inosisi4141
    すみませんです。

    現在のデータ
    A列
    ABC

    以下2000行に存在する


    追加したい項目
    B列   C列  D列 E列
    ゲスト 男性  1800 不明

    を以下2000行にコピーする


    上記作業を20ファイルに一度に行う
    ことがマクロまたは関数でできますか。

  • id:SALINGER
    1つ書き忘れました。
    実行するマクロのブックは追加するブックと別の場所に作ってください。
  • id:taknt
    >A列 ABC

    この ABCって 何を示してるんですか?

    >以下2000行に存在する

    2万行も いらないんですね?

    >追加したい項目
    固定でいいんですか?

    >上記作業を20ファイルに一度に行う

    一つ作って それをコピーすればいいんじゃないですか?



  • id:SALINGER
    >そのうちの1個のファイルからマクロを実実行しました。
    この上にも書きましたが、そのフォルダ以外のブックから実行することを想定して作っています。
    >フォルダ名を聞いてきましたがフォルダを選択できません
    フォルダ選択ダイアログですので選択できないということはありません。
  • id:inosisi4141
    A列はデータです
    データが2000から20000あるとマクロと関数では処理時間がどれくらい差があるか
    コピー貼り付けの方が早いか
    20ファイル同じ作業をする時間を少なくしたい
    マクロでやるとその時間にほかの作業ができる


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

    よろしくお願いします
  • id:SALINGER
    >もしCSVの場合はXLSとXLSXをCSVに変更すればよいのでしょうか
    CSVを増やすとしたら変更する箇所は
    If LCase(FSO.GetExtensionName(fil)) = "xls" Or _
    LCase(FSO.GetExtensionName(fil)) = "xlsx" Then

    If LCase(FSO.GetExtensionName(fil)) = "xls" Or _
    LCase(FSO.GetExtensionName(fil)) = "xlsx" Or _
    LCase(FSO.GetExtensionName(fil)) = "csv" Then
  • id:taknt
    速くしたつもりだったけど 速くならなかったみたい・・・。

    ま、手入力が いらない分 速いかと。
  • id:inosisi4141
    ありがとうございます。
    実データで試しましたら上手くゆきました。
    1ホルダーにファイル数が120位ありましたので
    楽な感じで作業できました。
    ただCSV場合は保存確認がファイル毎にでてきますので
    その分手間がかかるようですが
    これはCSVなのでしょうがないのですね。

  • id:SALINGER
    私の環境でテストしてもCSVで保存確認が出ないですが。
    試しに、最後の方の保存するコードを次のようにDisplayAlertで囲んで試してみてください。
     
    wb.Save
    wb.Close

    Application.DisplayAlerts = False
    wb.Save
    wb.Close
    Application.DisplayAlerts = True
  • id:taknt
    p = "C:\test\"

    これは 実行したいフォルダのパスです。
    ここに指定してもらえればいいです。

    あと このマクロが入った エクセルファイルを そのフォルダの中に入れておくと 開けなかったりするので
    入れないでくださいということです。


    >ただCSV場合は保存確認がファイル毎にでてきますので

    マクロの最初のほうに
    Application.DisplayAlerts = False
    というのを 入れると 確認してきません。
  • id:inosisi4141
    ありがとうございます。
    下記のように修正したらでなくなりました。
    ありがとうございました。

    Application.DisplayAlerts = False
    wb.Save
    wb.Close
    Application.DisplayAlerts = True

  • id:inosisi4141
    takntさん
    ありがとうございました。
    上手くゆきました。
    200ファイルで6分位でした早いです。
    データは平均4000件くらいでした。

    明日また別のファイルで試してみます。
  • id:inosisi4141
    takntさん
    恐れ入ります。お手数ですが
    1行目からのデータに対応するためには
    どこの部分を修正すれば良いか教えてください。
    よろしくお願いします。
  • id:taknt
    b = w.Sheets(1).Range("A2").End(xlDown).Row

    b = w.Sheets(1).Range("A1").End(xlDown).Row





    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")))



    w.Sheets(1).Range("B1") = "ゲスト"
    w.Sheets(1).Range("C1") = "男性"
    w.Sheets(1).Range("D1") = "1800"
    w.Sheets(1).Range("E1") = "不明"

    w.Sheets(1).Range("B1:E1").Copy (w.Sheets(1).Range(w.Sheets(1).Cells(2, "B"), w.Sheets(1).Cells(b, "E")))

    とすればいいです。


  • id:inosisi4141
    ありがとうございます。
    上手くゆきました。
    自分でやったのですが(3, "B"),を(2, "B"),にできなくて上手くゆきませんでした。

    前回の質問でA列の
    この ABCって 何を示してるんですか?

    意味が良くわからなったのですが
    実際のデータで並びが変わる場合がでてきました。
    A列のデータ
    abc@docomo.ne.jp
    がB列にある場合があります
    事前にチェックするのですが万一の場合を考えて
    その場合はC列からコピーを始めるマクロはできますか。
    よろしくおねがいします。


  • id:SALINGER
    B列にデータが入っていた場合、その行だけC列からになり1列ずれるという感じでしょうか。
    その場合は、各行のチェックが入るので速度が犠牲になりますがよろしいでしょうか。
  • id:inosisi4141
    A列のデータ
    abc@docomo.ne.jp
    がB列にある場合があります
    事前にチェックするのですが万一の場合を考えて
    その場合はC列からコピーを始めるマクロはできますか。

    この場合必ずアドレスのみです。

    実はB列にはすでに性別の男性または女性が入っています
    現在はB列のそこを上書きしているわけですが

    A列に男性または女性
    B列にアドレスのデータ
    の場合上書きしてしますとまずいので
    そのB列の内容を判断してC列からコピーするようにしたいのです。
    その場合のA列はマクロ後、手動で削除します

    よろしくおねがいします。

  • id:inosisi4141
    SALINGERさん
    速度が犠牲になる場合は迷いますが
    事前にチェックしたほうが早いと思います。
    Windows7はエクスプローラでファイルをみると右側に内容が表示
    されますので判断は早いのです。
    ファイルを開かないで内容が見れるという意味です。
  • id:inosisi4141
    takntさん

    スピードが犠牲になるようでしたら
    B列チェックの質問は取り消しますので
    よろしくお願いいます。
    すみませんでした。
  • id:SALINGER
    エクスプローラで開かずに確認できるということは、行毎にバラバラではなく
    ファイル毎に
    A列全てがアドレス B列全てが男性または女性
    A列全てが男性または女性 B列全てがアドレス
    の2通りがあるということでしょうか?
    「男性」、「女性」の文字列がどちらかに必ず入っていますか?
    そこら辺がわかればA列削除も全て自動化できるので。
  • id:inosisi4141
    はいそうゆうことです。
    説明不足ですみません。

    1ファイルのデータの並びは

    パターン1
    A列すべてがアドレス(@マークあり)
    B列はすべてが男性かまたは女性

    パターン2
    例外として(全部のファイルで1個か2個くらい)
    A列すべてが男性かまたは女性
    B列すべてがアドレス(@マークあり)

    「男性」、「女性」の文字列はどちらも入っています。

    C列の男性、女性はB列にもともとある男性、女性を使っても良いわけです。
    例外的にA列に男性、女性がある場合もありますが消さずに使ってもありです。

    よろしくお願いします。
  • id:SALINGER
    該当のファイルのA2セルが"男性"か"女性"が入力されているかで判断しています。(stRow=2の場合)
    CSVファイルをExcelで開いたときにA2が"男性"か"女性"と一字一句同じかどうか
    前後に空白などが入っていないかを確認してみてください。
  • id:inosisi4141
    お世話様です。

    原因不明なようです。
    この場合のA列のデータは事前に確認しないため
    不一致が起こる可能性がありますので
    事前に確認してその時点でA列B列を入れ替えて
    以前のA列アドレスB列性別の状態のみでマクロ実行したほうが
    手間がかからないようですのですみませんでした。
  • id:SALINGER
    最後に試しに、次のような変更では駄目ですか?
    If .Cells(stRow, "A").Value = "男性" Or _
    .Cells(stRow, "A").Value = "女性" Then

    If InStr(1, .Cells(stRow, "B").Value, "@") > 0 Then
  • id:inosisi4141
    だびたび申し訳ありません。

    If .Cells(stRow, "A").Value = "男性" Or _
    .Cells(stRow, "A").Value = "女性" Then

    If InStr(1, .Cells(stRow, "B").Value, "@") > 0 Then

    に変更しても
    どうしてもA列に性別が残りB列にあったアドレスが
    消えてしまいます。
    C列以降は正常にコピーされます。

    もう少しいろいろやってみます。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません