• 締切済み

エクセル2000VBAで質問です。

デスクトップ上に「T」というフォルダがあり、そこに「x05.txt」という カンマ区切りファイルがあるのですが、 そのファイルの内容を デスクトップ上の実績フォルダ内の「book1.xls」sheet1に、 カンマ区切りで貼り付けていく処理をしたいのです。 「x05.txt」の05は、作成した日付が?月5日という意味です。 貼り付けも、上書きではなくA1に1日のデータ、その続きの行の1列目に2日目のデータを貼り付ける という風にしたいのですが・・・さっぱりです。 OSは、WindowsXPです。 どうか、よろしくお願いいたします。 以下、作っている途中のプログラムです。 * 変数の宣言を抜いております。 Sub データ結合() SYSBASE = ActiveWorkbook.Name res = MsgBox("累積処理を開始します。", vbOKCancel) If res = vbCancel Then Exit Sub End If Workbooks(SYSBASE).Sheets("累積データ").Activate Cells.Delete For h = 1 To 31 メインパス名 = ActiveWorkbook.Path 日付パス名 = Right("00" + Mid(Str(h), 2), 2) On Error GoTo オープンエラー ChDir メインパス名 + "\" + 日付パス名 On Error GoTo 0 If ermsg = 1 Then ermsg = 0 Else ermsg = 0 For i = 1 To 10 ファイル名 = "T-LOG1_" + Right("00" + Mid(Str(i), 2), 2) On Error GoTo オープンエラー Workbooks.Open Filename:=メインパス名 + "\" + 日付パス名 + "\" + "個別" + _ "\" + ファイル名 + ".txt" On Error GoTo 0 If ermsg = 1 Then ermsg = 0 Exit For End If Workbooks(SYSBASE).Sheets("累積データ").Activate datarec = Range("A1").CurrentRegion.Rows.Count If datarec = 1 And Cells(1, 1) = "" Then Workbooks(ファイル名 + ".txt").Activate Range(Cells(1, 1), Cells(1, 20)).Copy Workbooks(SYSBASE).Sheets("累積データ").Activate Cells(1, 1).Select ActiveSheet.Paste End If Workbooks(ファイル名 + ".txt").Activate D_datarec = Range("A1").CurrentRegion.Rows.Count If D_datarec <= 1 Then ActiveWorkbook.Close savechanges:=False Else Range(Cells(2, 1), Cells(D_datarec, 20)).Copy Workbooks(SYSBASE).Sheets("累積データ").Activate datarec = Range("A1").CurrentRegion.Rows.Count Cells(datarec + 1, 1).Select ActiveSheet.Paste Workbooks(ファイル名 + ".txt").Activate Application.DisplayAlerts = False ActiveWorkbook.Close savechanges:=False Application.DisplayAlerts = True End If Next i End If Next h Exit Sub オープンエラー: ermsg = 1 Resume Next End Sub

みんなの回答

  • nao-y
  • ベストアンサー率58% (111/190)
回答No.1

動作検証してないので、変なこと言ってたらごめんなさい。 で、すみませんが、何が「さっぱりです。」なんですか? 動作させると何かエラーが出るんですか? それとも、エラーは出ないけど意図しない動きをするんですか? とりあえず、ざっと見たところ ・book1.xlsのパスが上の説明とソースコード内で違う ・x05.txtについても同様 ・If datarec = 1 And Cells(1, 1) = "" Then ~ End If の部分は必要ない(ちなみに「Cells(1, 1) = ""」は「Cells(1, 1).Value = ""」と書きましょう) というところ以外は大丈夫そうな気がしますが…。 (表現をもっと簡潔にできる箇所はありますが)

pheriar
質問者

お礼

すみません、自己解決いたしました。 わざわざ返事いただいたのに申し訳ございませんでした。

関連するQ&A

  • VBA(エクセル)で教えて下さい。開いていないBOOKの貼り付け

    VBA(エクセル)で教えて下さい。開いていないBOOKのシートを開いているBOOKのシートに貼り付けで、開いているBOOKから開いていないBOOK名を指定したいのですが、 現在開いているエクセルです。 SHEETS(Type)のRANGE(A1)に閉じているBOOK名を入力します。 SHEETS(In)に閉じているBOOKのSHEETSを貼り付けたいのですが、 Ex = Sheets("Type").Range("A1")  が無いと閉じているEx.xlsを貼り付けます。 このExと言うBOOK以外も多々コピーしたいのですが、どのように書けば良いか分からず、 是非、教えて下さい。 Sub a1() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("In").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select 'If Worksheets(1).Name = "STEP1" Then ' Worksheets(1).Activate ' Cells.ClearContents ' Else 'Worksheets.Add(Before:=Worksheets(1)).Name = "一覧" 'End If   Ex = Sheets("Type").Range("A1")   Set wsSrc = ActiveSheet Workbooks.Open "C:\WINDOWS\デスクトップ\test\Ex.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub

  • エクセルVBAで解らない部分があります。

    エクセルVBAで解らない部分があるのでどなたか教えてください。 ある表から特定の日付を探して抜き出すVBAを組み込んだファイルに下記のような記述がありました。 y=1:i=1 do   set tmp=workbooks("B").sheets(1).rows(2).find(workbooks("A").sheets(1).cells(y,1),lookat:=xlwhole)   if not tmp is nothing then     Workbooks("B").sheets(2).cells(i,1)=workbooks("A").sheets(1).cells(y,1)     '~略~     i=i+1   end if   y=y+1 loop until y=workbooks("A").sheets(1).range("A65536").end(xlup).row この中の「y=1:i=1」がよくわかりません。どなたか解る方どういう意味か教えてくれませんか? よろしくお願いします。

  • VBAについて質問です。

    下記の様なコードがあり、EXCELのデータを別EXCELの指定シートの日付欄と合致させ、データを 貼り付けるという内容です。 ★部の所で実行時エラー '1004':RangeクラスのSelectメソッドが失敗しました。となってしまいます。 なぜか不明確なためアドバイスを宜しくお願い致します。 K2 = Range("K2") K3 = Range("K3") Dim wb As String Dim dy As String Dim dy2 As String Dim a As String dy = Range("K5") dy2 = Range("M1") Range("R5:R41").Copy wb = "D:\Documents and Settings\ssk\デスクトップ\" & dy & ".xls" Workbooks.Open (wb) Workbooks(dy & ".xls").Sheets("data").Select For n = 2 To 100 Step 1 a = Cells(1, n).Value If Cells(1, n).Value = dy2 Then Worksheets("data").Activate Cells(3, n).PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False End If Next 'err1: 'Excel.Application.CutCopyMode = False 'With ThisWorkbook 'If Workbooks.Count > 1 Then '.Saved = True ' .Close False ' Else ' .Saved = True ' Application.Quit '.Close ' End If 'End With End Sub

  • エクセルVBAについて教えてください。

    DSUMを使ってVBAで自動計算をさせたいのですがうまくいきません。  ・Sheetsデータにデータを置いていて、A1からU1610までデータが入ってます。  ・Sheets集計用は計算させるための(条件を入れる)シートで、A1からE列まで(選択する項目によって何行目になるかわかりません。)  ・mycountでE列のデータが入ってる行を出してます。  ・部屋タイプで1K~1LDKを選ぶとDSUMの式のタイプに1を入れたいのです。(1K~1LDKの場合はCells(1,3) 下記のように書いてみましたが上手くいきません。 どなたかご教授いただけると助かります。 mycount = "=COUNT(集計用!E2:E300)" Sheets("集計用").Cells(5, 7).Value = Range("g10") = " =DSUM(cells(データ!,1),1610,21),cells(データ!1,タイプ),cells(集計用!),cells(mycount,5))" '部屋タイプの選択 If Sheets("フォーム").Range("c30") = "1K~1LDK" then  タイプ = 3 ElseIf Sheets("フォーム").Range("c30") = "2K~2LDK" Then タイプ = 6 ElseIf Sheets("フォーム").Range("c30") = "3K~3LDK" Then  タイプ = 9 ElseIf Sheets("フォーム").Range("c30") = "4K~4LDK" Then タイプ = 12 Else Sheets("フォーム").Range("c30") = "その他" Then タイプ = 15 End If

  • VBAを実行するとエクセルが落ちる

    同一フォルダ内にあるCSVデータを一つのエクセルにワークブックにまとめるため CSVデータを開いて、各シートに値を貼り付けるVBAを作成しました デバックモードで1行毎に実行するとエクセルが落ちることはありませんが 普通に実行するとエクセルが閉じてしまいます 原因が分からないためご指摘いただけると幸いです Win7のOffice2013です。 Sub contents() Sheets("01").Select Sheets("01").Cells.Select Selection.ClearContents Dim ShA As Worksheet Dim FileA As String Set ShA = ThisWorkbook.Sheets("01") ChDir "C:\Users\Public\Documents" FileA = "C:\Users\Public\Documents\01.csv" If FileA <> "False" Then Workbooks.OpenText Filename:=FileA, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlTextQualifierNone, Comma:=True ActiveSheet.Cells.CurrentRegion.Copy Destination:=ShA.Range("A1") ActiveWorkbook.Close False End If Set ShA = Nothing Sheets("02").Select Sheets("02").Cells.Select Selection.ClearContents Dim ShB As Worksheet Dim FileB As String Set ShB = ThisWorkbook.Sheets("02") ChDir "C:\Users\Public\Documents" FileB = "C:\Users\Public\Documents\02.csv" If FileB <> "False" Then Workbooks.OpenText Filename:=FileB, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlTextQualifierNone, Comma:=True ActiveSheet.Cells.CurrentRegion.Copy Destination:=ShB.Range("A1") ActiveWorkbook.Close False End If Set ShB = Nothing Sheets("03").Select Sheets("03").Cells.Select Selection.ClearContents Dim ShC As Worksheet Dim FileC As String Set ShC = ThisWorkbook.Sheets("03") ChDir "C:\Users\Public\Documents" FileC = "C:\Users\Public\Documents\03.csv" If FileC <> "False" Then Workbooks.OpenText Filename:=FileC, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlTextQualifierNone, Comma:=True ActiveSheet.Cells.CurrentRegion.Copy Destination:=ShC.Range("A1") ActiveWorkbook.Close False End If Set ShC = Nothing End Sub

  • エクセルVBAの転記処理について

    2つのエクセルのブックがあり、 ブックAの[シート1]には、 A列    B列     C列    D列  E列 コード   社名    品名    注文  合計 12345  グルメ社  カレー  400  800 78910  AA社    豆     100  250 12345  グルメ社  カレー  400  800 44123  ラック社  にんじん  350  400 のように、過去の注文データが1万件近くならんでおります。 ブックBの[現在]シートには、同じ列に同じ項目が並んでいるのですが、 A列    B列     C列    D列  E列 コード   社名    品名    注文  合計 12345  グルメ社  カレー  400  800 89123               100  250 55158                    800 44123  ラック社  にんじん  350  400 のように、コード以外空欄というセルがあり、それが4千件あります。 ブックBにてB列が空欄の場合、ブックAのB・C・D列の値を転記する方法がわからず 困っております。 Sub ああ() Dim lRow As Long Dim i As Long Dim エラーコード(25000) Workbooks.Open Filename:=("C:\Documents and Settings\PC01\デスクトップ\bookA.xls") Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate Sheets("sheet1").Select lRow = Cells(Rows.Count, 4).End(xlUp).Row x = "" cnt = 0 For i = 4 To lRow Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate Sheets("sheet1").Select If Cells(i, 2).Value = "" Then JAN = Cells(i, 1) Windows("book2.xls").Activate Sheets("現在").Select 商品datarec = Cells(Rows.Count, 1).End(xlUp).Row x = "" Set 範囲 = Range(Cells(2, 1), Cells(商品datarec, 1)) 検索 = JAN On Error Resume Next x = Application.WorksheetFunction.match(検索, 範囲, 0) On Error GoTo 0 If x = "" Then cnt = cnt + 1 エラーコード(cnt) = JAN Else Windows("book2.xls").Activate Sheets("現在").Select メーカー名 = Cells(x + 1, 5).Value 品名 = Cells(x + 1, 6).Value Workbooks("C:\Documents and Settings\PC01\デスクトップ\bookA").Activate Sheets("sheet1").Select Cells(i, 2) = 社名 Cells(i, 3) = 品名 End If End If Next i If cnt <> 0 Then MsgBox "リストにない商品が" + Str(cnt) + "件ありました。" + vbCrLf End If End Sub というプログラムを組みました。宣言は強制させておりません。 途中で混乱してきたためおかしなコードになっております。 すみませんが、お願い致します。

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.(5,2)がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)  ← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • Excel  VBAのマクロについて

    以下のようなマクロを作りました。 P4に開始番号P6に終わりの番号があるのですが、P4=P6、つまり、一つだけのシートを作成する分には問題なく動きます。しかしP4に1、P6に5と範囲を増やすとエラーが出て動きません。どこをなおしたらよろしいでしょうか? Option Explicit Sub 一括() Dim I As Worksheet Dim SheetName As String Dim Prompt As String Dim Col As Integer Dim Cell As Range Dim Row As Long Dim hani As Long For hani = Range("P4").Value To Range("P6").Value Set I = ActiveSheet SheetName = Cells(hani + 4, "K").Value & "(" & Cells(hani + 4, "B") & ")" Prompt = SheetName & "が存在します。" Sheets("基本シート").Copy After:=Sheets("基本シート") On Error GoTo 100 ActiveSheet.Name = SheetName On Error GoTo 0 Range("X3") = I.Cells(hani + 4, "B") Range("E8") = I.Cells(hani + 4, "C") Range("A13") = I.Cells(hani + 4, "D") For Col = 0 To 8 Step 4 Set Cell = I.Cells(hani + 4, "D").Offset(, Col) If Cell > 0 Then Prompt = "該当する日付がありません。" & Cell.Address On Error GoTo 100 Row = WorksheetFunction.Match(Cell, [A:A], 0) On Error GoTo 0 Cells(Row, "E") = I.Cells(hani + 4, "E").Offset(, Col) Cells(Row, "H") = I.Cells(hani + 4, "F").Offset(, Col) If Col < 8 Then Cells(Row, "Y") = I.Cells(hani + 4, "G").Offset(, Col) End If End If Next Col Next hani End 100 If Err <> 1004 Then Error Err End End If MsgBox Prompt, vbCritical Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True Sheets(1).Select End Sub

  • EXCEL VBA エラーの意味が分からず

    いつも、お世話になっております。 下記コードで、レコード1と2を前へと次へを繰り返し何度か操作すると、エラーになってしまいます。なぜエラーになって、どう修正すれば回避できるのかが分かりません。 どうかご教授いただけないでしょうか。よろしくお願いいたします。 エラーの状況 inputシートで、maeとtsugiの動作を何度か行うと、「If pict.TopLeftCell.Address = targetRange.Address Then」の部分が黄色く塗りつぶされ、「実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです。」と表示されてしまします。たぶん写真の削除の時にエラーになっているのだと思いますが、 '■標準モジュールのコード。dataシートのレコードを移動し、inputシートのBC1セルに表示する。 Public trg As Range Sub Saisyo() Set trg = Worksheets("data").Range("A1") Do Set trg = trg.Offset(1, 0) Loop Until trg.EntireRow.Hidden = False Call Tenki End Sub Sub Saigo() Set trg = Worksheets("data").Range("A60000").End(xlUp) Call Tenki End Sub Sub Mae() On Error GoTo errhandle If trg.row >= 3 Then Do Set trg = trg.Offset(-1, 0) Loop Until trg.EntireRow.Hidden = False If trg.row = 1 Then MsgBox "これより前のレコードはありません" Call Saisyo Exit Sub Else Call Tenki End If Else MsgBox "これより前のレコードはありません!" End If Exit Sub errhandle: Call Saisyo End Sub Sub Tsugi() On Error GoTo errhandle If trg.row < Worksheets("data").Range("A60000").End(xlUp).row Then Do Set trg = trg.Offset(1, 0) Loop Until trg.EntireRow.Hidden = False Call Tenki Else MsgBox "これより後ろのレコードはありません" End If Exit Sub errhandle: Call Saigo End Sub Sub Tenki() Worksheets("input").Range("BC1").Value = trg.Offset(0, 0) End Sub '■sheet 1のモジュール。inputシートBC1セルの値を見て、dataシートへ値を読みにいき、inputシートへ表示する。 Private Sub hyouji() Dim fRange As Range Dim kensaku As Long Set fRange = Sheets("data").Columns(1).Find(What:=Range("BC1").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) If (fRange Is Nothing) Then '見つからなかった? MsgBox "入力された顧客コードが存在しません。", vbExclamation Exit Sub End If kensaku = fRange.row '検索された顧客DCの行位置を求める Range("BC1:BE1").Value = Sheets("data").Cells(kensaku, 1).Value '整理No Range("AX1").Value = Sheets("data").Cells(kensaku, 2).Value '固有ID Range("I4").Value = Sheets("data").Cells(kensaku, 3).Value '工場名 Range("P4").Value = Sheets("data").Cells(kensaku, 4).Value '柱No Range("W4").Value = Sheets("data").Cells(kensaku, 5).Value '盤No Range("I5").Value = Sheets("data").Cells(kensaku, 6).Value '変台系統1 Range("S5").Value = Sheets("data").Cells(kensaku, 7).Value '変台系統2 Range("I6").Value = Sheets("data").Cells(kensaku, 8).Value '分電盤設置時期 Range("B8").Value = Sheets("data").Cells(kensaku, 9).Value '主な供給先 Range("B14").Value = Sheets("data").Cells(kensaku, 10).Value '特記 Range("AD4").Value = Sheets("data").Cells(kensaku, 11).Value '盤位置の目安 Range("AT8").Value = Sheets("data").Cells(kensaku, 12).Value '幹線線相 Range("R36").Value = Sheets("data").Cells(kensaku, 13).Value '盤写真ファイル名 Range("AT36").Value = Sheets("data").Cells(kensaku, 14).Value '単結図ファイル名 End Sub '■sheet 1のモジュール。"$R$36"と"$AT$36"の写真ファイル名を見て、"C37"と"AE37"セルに表示させる。 Private Sub Worksheet_Change(ByVal Target As Range) Dim fRange As Range Dim touroku As Long Select Case Target.Address Case "$BC$1" Call hyouji Case "$R$36" myLoadPicture "board_Image", Target.Text, Range("C37") Case "$AT$36" myLoadPicture "map_Image", Target.Text, Range("AE37") Case "$AT$8" Call red_circle Case Else Exit Sub End Select End Sub Private Sub myLoadPicture(folderName As String, fname As String, targetRange As Range) Dim pict As Shape, picPath As String picPath = ThisWorkbook.Path & "\" & folderName & "\" & fname If fname = "" Then picPath = ThisWorkbook.Path & "\" & folderName & "\" & "NoImage.jpg" End If With ActiveSheet For Each pict In .Shapes If pict.TopLeftCell.Address = targetRange.Address Then pict.Delete Exit For End If Next pict Set pict = .Shapes.AddPicture(picPath, msoTrue, msoFalse, _ targetRange.Left, targetRange.Top, 300, 360) End With End Sub

  • エクセルVBA  どうしても動きません。

    お世話になります。 なかなか上達しない超初心者です。 ↓↓ですが、Activesheetにすると動くのに、シート名を元々存在するシート”実験"に指定すると動きません(データ内容はまったく同じで、A列に色んな名前が入っていて、重複しているとC列に重複と入力します)。 2日間試行錯誤したのですが、やっぱり動かず・・・ ちなみに、Activateにするとアクティブになるし、CurrentRegionも選択できるのに なんでうごかないんでしょうか・・・ 何卒ご指導くださいませ。よろしくお願いいたします!!!!!! Sub Test2() With Sheets("実験").Range("A1").CurrentRegion Dim i As Long Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row For i = 1 To LastRow If WorksheetFunction.CountIf(Range("A:A"), Cells(i, 1)) > 1 Then Cells(i, 3) = "重複" End If Next i End With End Sub Sheets("実験")をActivesheetに変えると別のシートがしっかり動いてくれます・・・が、なんとしてでも”実験”シートに動いていただきたいです・・・。

専門家に質問してみよう