Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


10071 / 13646 ツリー ←次へ | 前へ→

【23420】他のbookに値を書き込む方法 sakura 05/3/22(火) 18:01 質問[未読]
【23421】Re:他のbookに値を書き込む方法 kazu 05/3/22(火) 18:57 発言[未読]
【23459】Re:他のbookに値を書き込む方法 sakura 05/3/24(木) 13:20 質問[未読]
【23460】Re:他のbookに値を書き込む方法 sakura 05/3/24(木) 13:42 質問[未読]
【23464】Re:他のbookに値を書き込む方法 Jaka 05/3/24(木) 14:25 回答[未読]
【23491】Re:他のbookに値を書き込む方法 sakura 05/3/24(木) 17:30 発言[未読]
【23492】Re:他のbookに値を書き込む方法 Jaka 05/3/24(木) 17:39 発言[未読]
【23501】Re:他のbookに値を書き込む方法 sakura 05/3/24(木) 19:09 発言[未読]
【23522】Re:他のbookに値を書き込む方法 Jaka 05/3/25(金) 14:19 回答[未読]
【23532】Re:他のbookに値を書き込む方法 sakura 05/3/25(金) 18:00 発言[未読]
【23595】Re:他のbookに値を書き込む方法 Jaka 05/3/29(火) 17:06 回答[未読]
【23497】Re:他のbookに値を書き込む方法 kazu 05/3/24(木) 18:12 発言[未読]
【23502】Re:他のbookに値を書き込む方法 sakura 05/3/24(木) 19:11 発言[未読]
【23537】Re:他のbookに値を書き込む方法 sakura 05/3/25(金) 19:07 発言[未読]
【23559】Re:他のbookに値を書き込む方法 kazu 05/3/28(月) 12:48 発言[未読]
【23797】Re:他のbookに値を書き込む方法 sakura 05/4/4(月) 19:00 質問[未読]
【23799】さらにパワーアップ sakura 05/4/4(月) 19:38 発言[未読]
【23890】Re:さらにパワーアップ sakura 05/4/6(水) 17:27 お礼[未読]

【23420】他のbookに値を書き込む方法
質問  sakura  - 05/3/22(火) 18:01 -

引用なし
パスワード
   初めて投稿させていただきます。

こんな方法ができるのかどうかというのを知りたくてGoogle検索をかけて
いましたら、教えていただけそうな掲示板を見つけてアドバイスを頂けな
いかと思い投稿させていただきました。

現在マクロでVBAを触っております。
ファイルA.txtを読み込んで加工などをしたものbookA.xlsに書き出したい
のです。

ファイルA.txtを読み込んだ結果は以下の通りです。
 | A | B | C | D | E | F |
1| 種類 | 名 | 在庫 |   |   |   |
2| 果物 |リンゴ| 1 |   |   |   |
3| 果物 |メロン| 4 |   |   |   |
4| 果物 | モモ | 3 |   |   |   |
5| 野菜 |トマト| 2 |   |   |   |
6| 野菜 | 白菜 | 1 |   |   |   |
7| 野菜 |玉ねぎ| 3 |   |   |   |
8| 果物 |バナナ| 2 |   |   |   |
9| 野菜 | 大根 | 3 |   |   |   |
10| 野菜 | ナス | 1 |   |   |   |

このファイルA.txtを読み込むためのマクロはすでに完成しています。
そこで、なんらかのマクロを利用してbookA.xlsに以下のように書き出せ
ないでしょうか??果物シートには果物を、野菜シートには野菜を!!
すでに果物シート、野菜シートには名前の欄にはリンゴやバナナ、ナス、
大根と記入されている状態です。在庫の欄に数値をコピペできたらいいわけ
なんですけど・・・
 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|リンゴ| 1 |   |   |   |   |
3|メロン| 4 |   |   |   |   |
4| モモ | 3 |   |   |   |   |
5|バナナ| 2 |   |   |   |   |
6|   |   |   |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
    ______________________________________
\果物/\野菜/


 | A | B | C | D | E | F |
1| 種類 | 名 | 在庫 |   |   |   |
2| 野菜 |トマト| 2 |   |   |   |
3| 野菜 | 白菜 | 1 |   |   |   |
4| 野菜 |玉ねぎ| 3 |   |   |   |
5| 野菜 | 大根 | 3 |   |   |   |
6| 野菜 | ナス | 1 |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
_______    _______________________________
\果物/\野菜/

利用するユーザーが違うことからパソコン端末もことなっていることから、
bookAのディレクトリを取得して動作するようになればと思います。

一応、以下のマクロは作ってあります。
ファイルA.txtの読み込みマクロ
Public buf1 As String
  ChDir "C:\"
  buf1 = Application.GetOpenFilename("*.txt,*.txt")
  If buf1 = "False" Then Exit Sub
  Workbooks.OpenText Filename:=buf1, _
            Origin:=xlWindows, _
            StartRow:=1, _
            DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, _
            Tab:=False, _
            Semicolon:=False, _
            Comma:=True, _
            Space:=False, _
            Other:=False, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), _
                    Array(3, 1), Array(4, 1), _
                    Array(5, 1), Array(6, 1), _
                    Array(7, 1), Array(8, 1)), _
            TrailingMinusNumbers:=True


bookAを読み込むためのマクロ
Public buf2 As String
Sub bookAの指定()
  ChDir "C:\"
  buf2 = Application.GetOpenFilename("*.xls,*.xls")
  If buf2 = "False" Then Exit Sub
End Sub


ファイルA.txtのA列とB列の値を読み込んでbookA.xlsのシート名とA列
を比較して、bookA.xlsの一致する箇所のB列にファイルA.txtのC列の値
をコピペできたらいいんだろうと思いますが・・・

以上、長文でわかりにくくて大変申し訳ありませんが何かアドバイスを頂けたらと思います。

【23421】Re:他のbookに値を書き込む方法
発言  kazu  - 05/3/22(火) 18:57 -

引用なし
パスワード
   ▼sakura さん:


こんな感じでどうでしょう?
(TrailingMinusNumbers:=Trueは自分が97環境でデバックしたのでコメントアウトさせてもらいました。)


Sub Sample()
Dim buf2 As String

  ChDir "C:\"
  buf1 = Application.GetOpenFilename("*.txt,*.txt")
  If buf1 = "False" Then Exit Sub
  Workbooks.OpenText FileName:=buf1, _
            Origin:=xlWindows, _
            StartRow:=1, _
            DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, _
            Tab:=False, _
            Semicolon:=False, _
            Comma:=True, _
            Space:=False, _
            Other:=False, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), _
                    Array(3, 1), Array(4, 1), _
                    Array(5, 1), Array(6, 1), _
                    Array(7, 1), Array(8, 1))
'            TrailingMinusNumbers:=True


  Set ObjSht1 = ActiveWorkbook.ActiveSheet
  
  ChDir "C:\"
  buf2 = Application.GetOpenFilename("*.xls,*.xls")
  If buf2 = "False" Then Exit Sub
  Workbooks.Open buf2
  
  Set ObjBook1 = ActiveWorkbook
  
  For Each Cel In ObjSht1.Range(ObjSht1.Cells(1, 1), ObjSht1.Cells(65000, 1).End(xlUp))
    If Trim(Cel.Value) = "野菜" Then
      Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
      Do Until Cel2 Is Nothing
        Cel.EntireRow.Copy Cel2.EntireRow
        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
      Loop
    ElseIf Trim(Cel.Value) = "果物" Then
      Set Cel2 = ObjBook1.Sheets("果物").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
      Do Until Cel2 Is Nothing
        Cel.EntireRow.Copy Cel2.EntireRow
        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
      Loop
    End If
    Set Cel2 = Nothing
  Next
  
  ObjBook1.Close True
  Set ObjBook1 = Nothing
  ObjSht1.Application.ActiveWorkbook.Close False
  Set ObjSht1 = Nothing
End Sub

【23459】Re:他のbookに値を書き込む方法
質問  sakura  - 05/3/24(木) 13:20 -

引用なし
パスワード
   ▼kazu さん:
>Sub Sample()
>Dim buf2 As String
>
>  ChDir "C:\"
>  buf1 = Application.GetOpenFilename("*.txt,*.txt")
>  If buf1 = "False" Then Exit Sub
>  Workbooks.OpenText FileName:=buf1, _
>            Origin:=xlWindows, _
>            StartRow:=1, _
>            DataType:=xlDelimited, _
>            TextQualifier:=xlDoubleQuote, _
>            ConsecutiveDelimiter:=False, _
>            Tab:=False, _
>            Semicolon:=False, _
>            Comma:=True, _
>            Space:=False, _
>            Other:=False, _
>            FieldInfo:=Array(Array(1, 1), Array(2, 1), _
>                    Array(3, 1), Array(4, 1), _
>                    Array(5, 1), Array(6, 1), _
>                    Array(7, 1), Array(8, 1))
>'            TrailingMinusNumbers:=True
>
>
>  Set ObjSht1 = ActiveWorkbook.ActiveSheet
>  
>  ChDir "C:\"
>  buf2 = Application.GetOpenFilename("*.xls,*.xls")
>  If buf2 = "False" Then Exit Sub
>  Workbooks.Open buf2
>  
>  Set ObjBook1 = ActiveWorkbook
>  
>  For Each Cel In ObjSht1.Range(ObjSht1.Cells(1, 1), ObjSht1.Cells(65000, 1).End(xlUp))
>    If Trim(Cel.Value) = "野菜" Then
>      Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
>      Do Until Cel2 Is Nothing
>        Cel.EntireRow.Copy Cel2.EntireRow
>        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
>      Loop
>    ElseIf Trim(Cel.Value) = "果物" Then
>      Set Cel2 = ObjBook1.Sheets("果物").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
>      Do Until Cel2 Is Nothing
>        Cel.EntireRow.Copy Cel2.EntireRow
>        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
>      Loop
>    End If
>    Set Cel2 = Nothing
>  Next
>  
>  ObjBook1.Close True
>  Set ObjBook1 = Nothing
>  ObjSht1.Application.ActiveWorkbook.Close False
>  Set ObjSht1 = Nothing
>End Sub

なんですけど・・・
Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
って
Set Cel2 = ObjBook1.Sheets("果物").Columns(1).FindNext(Cel2)
ですよね??

モジュールに保存処理、振り分け処理をした場合ってどんな感じになるか教えていただけませんか??

お手数ですがよろしくおねがいします。

【23460】Re:他のbookに値を書き込む方法
質問  sakura  - 05/3/24(木) 13:42 -

引用なし
パスワード
   >モジュールに保存処理、振り分け処理をした場合ってどんな感じになるか教えていただけませんか??

すみません。
日本語になってませんね・・・

保存処理のモジュールと振り分け処理のモジュールに分けれたらどんな感じになるか教えていただけないでしょうか?
ってことです^^;

【23464】Re:他のbookに値を書き込む方法
回答  Jaka  - 05/3/24(木) 14:25 -

引用なし
パスワード
   こんにちは。

こんな感じにオートフィルタを使ったほうが簡単そうですけど...。
テキストを開いた後のコード。
テキストを開いてから実行するので、アクティブになっているはずだから、ブック名シート名は特に指定してません。
野菜、果物シートのレイアウトが違うみたいですが、果物シートにあわせました。
適当にカスタマイズしてください。

AERw = Range("A65536").End(xlUp).Row
Range("A1").AutoFilter Field:=1, Criteria1:="果物"
Range("B1:B" & AERw).SpecialCells(xlCellTypeVisible).Copy
Workbooks("bookA.xls").Sheets("果物").Range ("A1")
Range("C1:C" & AERw).SpecialCells(xlCellTypeVisible).Copy
Workbooks("bookA.xls").Sheets("果物").Range ("B1")

Range("A1").AutoFilter Field:=1, Criteria1:="野菜"
Range("B1:B" & AERw).SpecialCells(xlCellTypeVisible).Copy
Workbooks("bookA.xls").Sheets("野菜").Range ("A1")
Range("C1:C" & AERw).SpecialCells(xlCellTypeVisible).Copy
Workbooks("bookA.xls").Sheets("野菜").Range ("B1")

【23491】Re:他のbookに値を書き込む方法
発言  sakura  - 05/3/24(木) 17:30 -

引用なし
パスワード
   ▼Jaka さん:
レスありがとうございます。

すみません

うまく伝えることができていなかったようです。

私の書き方が間違っていました。


ファイルA.txt
 | A | B | C | D | E | F |
1| 種類 | 名 | 在庫 |   |   |   |
2| 果物 |リンゴ| 1 |   |   |   |
3| 果物 |メロン| 4 |   |   |   |
4| 果物 | モモ | 3 |   |   |   |
5| 野菜 |トマト| 2 |   |   |   |
6| 野菜 | 白菜 | 1 |   |   |   |
7| 野菜 |玉ねぎ| 3 |   |   |   |
8| 果物 |バナナ| 2 |   |   |   |
9| 野菜 | 大根 | 3 |   |   |   |
10| 野菜 | ナス | 1 |   |   |   |


をbookA.xls
 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|リンゴ| 1 |   |   |   |   |
3|メロン| 4 |   |   |   |   |
4| モモ | 3 |   |   |   |   |
5|バナナ| 2 |   |   |   |   |
6|   |   |   |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
    ______________________________________
\果物/\野菜/



 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|トマト| 2 |   |   |   |   |
3| 白菜 | 1 |   |   |   |   |
4|玉ねぎ| 3 |   |   |   |   |
5| 大根 | 3 |   |   |   |   |
6| ナス | 1 |   |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
_______    _______________________________
\果物/\野菜/

というような形です。

すみませんでした。

大変お手数をおかけしますがよろしくお願いします。

bookA.xlsのA列を判断してB列に在庫数をいれていきたいんです・・・

【23492】Re:他のbookに値を書き込む方法
発言  Jaka  - 05/3/24(木) 17:39 -

引用なし
パスワード
   ▼sakura さん:
 略
>bookA.xlsのA列を判断してB列に在庫数をいれていきたいんです・・・
そんな感じになりませんでしたか?

もしかしてbookA.xlsのA列の項目名は先に書かれてあるんですか?

【23497】Re:他のbookに値を書き込む方法
発言  kazu  - 05/3/24(木) 18:12 -

引用なし
パスワード
   sakura さんこんにちは。

とりあえず私の書いたコードについて簡単に説明いれときますね。

Celは 開いたテキストファイルの A1 → A2 → A3 ・・・・・・とA列の最終行迄1セルづつ変化していきます。


  For Each Cel In ObjSht1.Range(ObjSht1.Cells(1, 1), ObjSht1.Cells(65000, 1).End(xlUp))

    Celの値が野菜だった場合
    If Trim(Cel.Value) = "野菜" Then

      Celのひとつ右の列(CelがA2の場合B2セル)と同じ値が入っているセルを野菜シートのA列から検索し、結果をCel2 に格納(*1)
      (無かった場合はNothingが格納されます。)
      Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))

      Cel2 がNothingになる迄繰り返す
      Do Until Cel2 Is Nothing

        Cel2 の行にCelの行をコピー&ペースト
        Cel.EntireRow.Copy Cel2.EntireRow
        
        *1と同じ条件で次に同じ値が入っているセルを検索
        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
      Loop

    ElseIf Trim(Cel.Value) = "果物" Then
      Set Cel2 = ObjBook1.Sheets("果物").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))
      Do Until Cel2 Is Nothing
        Cel.EntireRow.Copy Cel2.EntireRow
        Set Cel2 = ObjBook1.Sheets("果物").Columns(1).FindNext(Cel2)
      Loop
    End If
    Set Cel2 = Nothing
  Next
  
  野菜シート,果物シートのあるBookを閉じる (上書きあり)
  ObjBook1.Close True
  Set ObjBook1 = Nothing
  ObjSht1.Application.ActiveWorkbook.Close False
  Set ObjSht1 = Nothing

【23501】Re:他のbookに値を書き込む方法
発言  sakura  - 05/3/24(木) 19:09 -

引用なし
パスワード
   ▼Jaka さん:

>もしかしてbookA.xlsのA列の項目名は先に書かれてあるんですか?

すみません。説明不足で申し訳ありません。

Jakaさんの推測通りです。bookA.xlsにはすでにトマトなどの項目

が存在してます。

存在してないものはマクロで追加できるようにはしていきたいとは

思っています。項目に存在していないものは後ほどで・・・と思って

ます。

説明不足ですみませんでした。

【23502】Re:他のbookに値を書き込む方法
発言  sakura  - 05/3/24(木) 19:11 -

引用なし
パスワード
   ▼kazu さん:
レスありがとうございます。

早速参考にさせてもらいマクロを組みたいと思います。

【23522】Re:他のbookに値を書き込む方法
回答  Jaka  - 05/3/25(金) 14:19 -

引用なし
パスワード
   こんにちは。

Sub djj()
  Dim TxSh As Worksheet, Cel As Range, Mat As Variant, ADC As Range

  'ここにファイルA.txtを開くコードが書いてあるとして
  'つまり、ファイルA.txtがアクティブ

  Set TxSh = ActiveSheet
  With Workbooks("bookA.xls")
    For Each Cel In TxSh.Range("B1", TxSh.Range("B65536").End(xlUp))
      Mat = Application.Match(Cel.Value, .Sheets("果物").Columns(1), 0)
      If Not IsError(Mat) Then
        .Sheets("果物").Cells(Mat, 2).Value = Cel.Offset(, 1).Value
      Else
        Mat = Application.Match(Cel.Value, .Sheets("野菜").Columns(1), 0)
        If Not IsError(Mat) Then
         .Sheets("野菜").Cells(Mat, 2).Value = Cel.Offset(, 1).Value
        Else
         Set ADC = .Sheets(Cel.Offset(, -1).Value).Range("A65536").End(xlUp).Offset(1)
         ADC.Value = Cel.Value
         ADC.Offset(, 1).Value = Cel.Offset(, 1).Value
        End If
      End If
    Next
  End With
  Set TxSh = Nothing
  Set ADC = Nothing
End Sub

【23532】Re:他のbookに値を書き込む方法
発言  sakura  - 05/3/25(金) 18:00 -

引用なし
パスワード
   ▼Jaka さん:
レスありがとうございます。


>Sub djj()
>  Dim TxSh As Worksheet, Cel As Range, Mat As Variant, ADC As Range
>
>  'ここにファイルA.txtを開くコードが書いてあるとして
>  'つまり、ファイルA.txtがアクティブ
>
>  Set TxSh = ActiveSheet
>  With Workbooks("bookA.xls")
>    For Each Cel In TxSh.Range("B1", TxSh.Range("B65536").End(xlUp))
>      Mat = Application.Match(Cel.Value, .Sheets("果物").Columns(1), 0)
>      If Not IsError(Mat) Then
>        .Sheets("果物").Cells(Mat, 2).Value = Cel.Offset(, 1).Value
>      Else
>        Mat = Application.Match(Cel.Value, .Sheets("野菜").Columns(1), 0)
>        If Not IsError(Mat) Then
>         .Sheets("野菜").Cells(Mat, 2).Value = Cel.Offset(, 1).Value
>        Else
>         Set ADC = .Sheets(Cel.Offset(, -1).Value).Range("A65536").End(xlUp).Offset(1)
>         ADC.Value = Cel.Value
>         ADC.Offset(, 1).Value = Cel.Offset(, 1).Value
>        End If
>      End If
>    Next
>  End With
>  Set TxSh = Nothing
>  Set ADC = Nothing
>End Sub

この場合bookA.xisのディレクトリがないように感じますが・・・

書き込み側のディレクトリも読み込むことができたらいいんですけど・・・

【23537】Re:他のbookに値を書き込む方法
発言  sakura  - 05/3/25(金) 19:07 -

引用なし
パスワード
   ▼kazu さん:
kazuさんご教授ねがいます。

>Cel2 の行にCelの行をコピー&ペースト
>Cel.EntireRow.Copy Cel2.EntireRow

なぜこの処理を行うのでしょうか??
セルの内容をコピペではなくセルの行をコピペなんですよね・・・


ここ以前までは納得行くのですが・・・
以降がなかなか理解できないんです。

すみません。お手数おかけしてしまって・・・・

【23559】Re:他のbookに値を書き込む方法
発言  kazu  - 05/3/28(月) 12:48 -

引用なし
パスワード
   ▼sakura さん:
値だけ書き出したい訳ですね・・・。
それなら以下を変更すれば出来ないですか?
(野菜しか記してないですが・・・果物も同様に変更が必要です。)

      Do Until Cel2 Is Nothing
        Cel.EntireRow.Copy Cel2.EntireRow
        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
      Loop

            ↓

      IF Not Cel2 Is Nothing Then
        FstCel2 = Cel2.Row
      Do
        Cel2.OffSet(0, 1).Value = Cel.Offset(0, 1).Value
        Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
      Loop Until Cel2 Is Nothing Or Cel2.Row = FstCel2
      End If

【23595】Re:他のbookに値を書き込む方法
回答  Jaka  - 05/3/29(火) 17:06 -

引用なし
パスワード
   >Sub djj()
>  Dim TxSh As Worksheet, Cel As Range, Mat As Variant, ADC As Range
   Dim ABK AS WorkBook
   ChDir "C:\"
   buf2 = Application.GetOpenFilename("*.xls,*.xls")
   If buf2 = "False" Then Exit Sub
   Set ABK = workbooks.Open(buf2)

>  'ここにファイルA.txtを開くコードが書いてあるとして
>  'つまり、ファイルA.txtがアクティブ
>
>  Set TxSh = ActiveSheet
>  With ABK
>    For Each Cel In TxSh.Range("B1", TxSh.Range("B65536").End(xlUp))

【23797】Re:他のbookに値を書き込む方法
質問  sakura  - 05/4/4(月) 19:00 -

引用なし
パスワード
   ▼kazu さん:

kazuさん返事遅くなりまして大変申し訳なかったですが・・・
以下のVBAで希望通りのことができました。
ありがとうございました。

Sub Sample()
Dim buf2 As String

  ChDir "C:\"
  buf1 = Application.GetOpenFilename("*.txt,*.txt")
  If buf1 = "False" Then Exit Sub
  Workbooks.OpenText Filename:=buf1, _
            Origin:=xlWindows, _
            StartRow:=1, _
            DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, _
            Tab:=False, _
            Semicolon:=False, _
            Comma:=True, _
            Space:=False, _
            Other:=False, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), _
                    Array(3, 1), Array(4, 1), _
                    Array(5, 1), Array(6, 1), _
                    Array(7, 1), Array(8, 1))
'            TrailingMinusNumbers:=True


  Set ObjSht1 = ActiveWorkbook.ActiveSheet
  
 
  ChDir "C:\"
  buf2 = Application.GetOpenFilename("*.xls,*.xls")
  If buf2 = "False" Then Exit Sub
  Workbooks.Open buf2
 
  Set ObjBook1 = ActiveWorkbook
 
  For Each Cel In ObjSht1.Range(ObjSht1.Cells(1, 1), ObjSht1.Cells(65000, 1).End(xlUp))
    If Trim(Cel.Value) = "野菜" Then
      Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))

      If Not Cel2 Is Nothing Then
        FstCel2 = Cel2.Row
        Do
         Cel2.Offset(0, 2).Value = Cel.Offset(0, 3).Value
         Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
        Loop Until Cel2 Is Nothing Or Cel2.Row = FstCel2
      End If

    ElseIf Trim(Cel.Value) = "果物" Then
      Set Cel2 = ObjBook1.Sheets("果物").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))

      If Not Cel2 Is Nothing Then
        FstCel2 = Cel2.Row
        Do
         Cel2.Offset(0, 2).Value = Cel.Offset(0, 3).Value
         Set Cel2 = ObjBook1.Sheets("果物").Columns(1).FindNext(Cel2)
        Loop Until Cel2 Is Nothing Or Cel2.Row = FstCel2
      End If


    End If
    Set Cel2 = Nothing
  Next
 
  ObjBook1.Close True
  Set ObjBook1 = Nothing
  ObjSht1.Application.ActiveWorkbook.Close False
  Set ObjSht1 = Nothing
End Sub

さらにパワーアップをさせたいのですが・・・

次レスで説明させてもらいます。

【23799】さらにパワーアップ
発言  sakura  - 05/4/4(月) 19:38 -

引用なし
パスワード
   ▼sakura さん:
さらにVBAのパワーアップを試みたいのですが・・・

ファイルA.txt
 | A | B | C | D | E | F |
1| 種類 | 名 | 在庫 |   |   |   |
2| 果物 |リンゴ| 1 |   |   |   |
3| 果物 |メロン| 4 |   |   |   |
4| 果物 | モモ | 3 |   |   |   |
5| 野菜 |トマト| 2 |   |   |   |
6| 野菜 | 白菜 | 1 |   |   |   |
7| 野菜 |玉ねぎ| 3 |   |   |   |
8| 果物 |バナナ| 2 |   |   |   |
9| 野菜 | 大根 | 3 |   |   |   |
10| 野菜 | ナス | 1 |   |   |   |
のエクセルに対して以下VBAを実行すると・・・

Sub Sample()
Dim buf2 As String

  ChDir "C:\"
  buf1 = Application.GetOpenFilename("*.txt,*.txt")
  If buf1 = "False" Then Exit Sub
  Workbooks.OpenText Filename:=buf1, _
            Origin:=xlWindows, _
            StartRow:=1, _
            DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, _
            Tab:=False, _
            Semicolon:=False, _
            Comma:=True, _
            Space:=False, _
            Other:=False, _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), _
                    Array(3, 1), Array(4, 1), _
                    Array(5, 1), Array(6, 1), _
                    Array(7, 1), Array(8, 1))
'            TrailingMinusNumbers:=True


  Set ObjSht1 = ActiveWorkbook.ActiveSheet
  
 
  ChDir "C:\"
  buf2 = Application.GetOpenFilename("*.xls,*.xls")
  If buf2 = "False" Then Exit Sub
  Workbooks.Open buf2
 
  Set ObjBook1 = ActiveWorkbook
 
  For Each Cel In ObjSht1.Range(ObjSht1.Cells(1, 1), ObjSht1.Cells(65000, 1).End(xlUp))
    If Trim(Cel.Value) = "野菜" Then
      Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))

      If Not Cel2 Is Nothing Then
        FstCel2 = Cel2.Row
        Do
         Cel2.Offset(0, 2).Value = Cel.Offset(0, 3).Value
         Set Cel2 = ObjBook1.Sheets("野菜").Columns(1).FindNext(Cel2)
        Loop Until Cel2 Is Nothing Or Cel2.Row = FstCel2
      End If

    ElseIf Trim(Cel.Value) = "果物" Then
      Set Cel2 = ObjBook1.Sheets("果物").Columns(1).Find(Trim(Cel.Offset(0, 1).Value))

      If Not Cel2 Is Nothing Then
        FstCel2 = Cel2.Row
        Do
         Cel2.Offset(0, 2).Value = Cel.Offset(0, 3).Value
         Set Cel2 = ObjBook1.Sheets("果物").Columns(1).FindNext(Cel2)
        Loop Until Cel2 Is Nothing Or Cel2.Row = FstCel2
      End If


    End If
    Set Cel2 = Nothing
  Next
 
  ObjBook1.Close True
  Set ObjBook1 = Nothing
  ObjSht1.Application.ActiveWorkbook.Close False
  Set ObjSht1 = Nothing
End Sub


をbookA.xls
 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|リンゴ| 1 |   |   |   |   |
3|メロン| 4 |   |   |   |   |
4| モモ | 3 |   |   |   |   |
5|バナナ| 2 |   |   |   |   |
6|   |   |   |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
    ______________________________________
\果物/\野菜/



 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|トマト| 2 |   |   |   |   |
3| 白菜 | 1 |   |   |   |   |
4|玉ねぎ| 3 |   |   |   |   |
5| 大根 | 3 |   |   |   |   |
6| ナス | 1 |   |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
_______    _______________________________
\果物/\野菜/

というような形になるのですが・・・
(初めの読み込みでファイルA.txt、二回目の読み込みでbookA.xlsを読み込んでます。)


仮に下記ファイルA.txtのようにゴーヤがあったとして・・・

ファイルA.txt
 | A | B | C | D | E | F |
1| 種類 | 名 | 在庫 |   |   |   |
2| 果物 |リンゴ| 1 |   |   |   |
3| 果物 |メロン| 4 |   |   |   |
4| 果物 | モモ | 3 |   |   |   |
5| 野菜 |トマト| 2 |   |   |   |
6| 野菜 | 白菜 | 1 |   |   |   |
7| 野菜 |玉ねぎ| 3 |   |   |   |
8| 果物 |バナナ| 2 |   |   |   |
9| 野菜 | 大根 | 3 |   |   |   |
10| 野菜 | ナス | 1 |   |   |   |
11| 野菜 |ゴーヤ| 2 |   |   |   |

下記のbookA.xlsのA列にゴーヤの項目がなかった場合
bookA.xls
 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|トマト| 2 |   |   |   |   |
3| 白菜 | 1 |   |   |   |   |
4|玉ねぎ| 3 |   |   |   |   |
5| 大根 | 3 |   |   |   |   |
6| ナス | 1 |   |   |   |   |
7|   |   |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
_______    _______________________________
\果物/\野菜/

さっきのマクロでは何も操作されないのですが・・・

項目にない場合は・・・
以下bookA.xlsのように一番下の項目(この場合A7)にゴーヤという項目を
付け足して在庫数もつけたしたいのです。
bookA.xls
 | A | B | C | D | E | F |
1| 名 | 在庫 |   |   |   |   |
2|トマト| 2 |   |   |   |   |
3| 白菜 | 1 |   |   |   |   |
4|玉ねぎ| 3 |   |   |   |   |
5| 大根 | 3 |   |   |   |   |
6| ナス | 1 |   |   |   |   |
7|ゴーヤ| 2 |   |   |   |   |
8|   |   |   |   |   |   |
9|   |   |   |   |   |   |
10|   |   |   |   |   |   |
_______    _______________________________
\果物/\野菜/

上記マクロを改良すればなんとかできそうではあると思うのですが・・・

アドバイスをいただけたらありがたいです。

【23890】Re:さらにパワーアップ
お礼  sakura  - 05/4/6(水) 17:27 -

引用なし
パスワード
   ちょっとがんばってみます。

みなさんありがとうございました。

10071 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free