• ベストアンサー
  • 困ってます

それぞれテキストファイに区切って出力

添付画像のような構成で  C列数値(D列の文字数の総計)を上から順番に合計して300を超えるとB列にその合計を書き出すようにしました。  (コード SumIfOver300) わかりやすいようにA列にそれぞれを塗分けしています。 1) 現在は、手動ですがこれをVBAで自動で処理したい。 (添付図は、3色ですが境目が解ればいいので2色でもOKです。) 2) 塗分け後に塗分けされたD列の部分を一つのテキスト群としてそれぞれ別ファイル(テキストファイル)に区切って出力したい。 添付図で言うといかのように出力  D2:D7  001_text.txt D8:D12 002_text.txt D13:D15 003_text.txt Sub SumIfOver300() Dim lastRow As Long Dim sum As Long Dim i As Long lastRow = Cells(Rows.Count, "C").End(xlUp).Row sum = 0 For i = 1 To lastRow sum = sum + Cells(i, "C").Value If sum > 300 Then Cells(i, "B").Value = sum sum = 0 End If Next i End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.28

>  </i>は、 >   fileContent = Replace(fileContent, "/", "%EF%BC%8F") >   実際は、< / i>に先に変換されているので無駄なコードになっているようです。 上記を fileContent = Replace(fileContent, "</i>","") の後に実行すればいいのではないですか。 置換の順番は、文字数の多いものから先にするといいのではないでしょうか。 ただ 「%」は必ず一番最初に置換 は、あのグループの中で他の置換の結果に「%」が含まれるから、それを置換しないようにするためです。 > 事前にReplaceで削除しておきたいのですが > どのようなコードになりますか ? fileContent = Replace(fileContent, "</i>","") と同じようにすればいいと思います。

NuboChan
質問者

お礼

ありがとうございます。 難しく考えていました。 アドバイスのように削除記号をひとつずつコードで追加すれば良いのですね。 ( <*> のようにワイルドカード的な処理を想定していました。) 以下のコードに変更してしばらくテストしてみます。 fileContent = Replace(fileContent, "%", "%25") fileContent = Replace(fileContent, "<i>", "") fileContent = Replace(fileContent, "</i>", "") fileContent = Replace(fileContent, "<b>", "") fileContent = Replace(fileContent, "</b>", "") fileContent = Replace(fileContent, "<BR>", "") fileContent = Replace(fileContent, "#", "%23") fileContent = Replace(fileContent, "/", "%EF%BC%8F") pStr = Replace(Replace(Replace(fileContent, vbCr, "%0D"), vbLf, "%0A"), " ", "%20") ’---------------------------------------------

その他の回答 (27)

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.27

> 結果ですが、今回も前回の以下の参考図と同じ結果です。 データが渡されている以上、DeepLの結果に関しては、なぜそうなるのかはご自身で調べてください。

NuboChan
質問者

お礼

>DeepLの結果に関しては、なぜそうなるのかはご自身で調べてください。 確かにおっしゃるとうりです。 DeepLに翻訳すべき英文が渡されている以上、それから先はDeepLの問題ですね。 ダメもとで< i >< / i > を削除して渡すようにすると翻訳されました。 具体的には、以下のコード追加しました。 fileContent = Replace(fileContent, "<i>", "") fileContent = Replace(fileContent, "</i>","")  </i>は、   fileContent = Replace(fileContent, "/", "%EF%BC%8F")   があるので   実際は、< / i>に先に変換されているので無駄なコードになっているようです。 そこで調べてみると字幕のフォーマットでは、他に以下のような書式があるようです。 < b >< / b >  太字 < i >< / i >  イタリック体 <BR>      改行 いずれにしても <文字列>は、翻訳時には不具合が出るようなので 事前にReplaceで削除しておきたいのですが どのようなコードになりますか ?

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.26

fileContent = Replace(fileContent, "%", "%25") fileContent = Replace(fileContent, "#", "%23") fileContent = Replace(fileContent, "/", "%EF%BC%8F") pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20") WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr fileName = Dir です。

NuboChan
質問者

補足

ありがとうございます。 アドバイスに従ってコードの位置を変更しました。 WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr fileName = Dir 変更後に同じサンプルで試してみました。 結果ですが、今回も前回の以下の参考図と同じ結果です。  参考画像 https://imgur.com/rqbRBht

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.25

> 翻訳が1行に結合された結果になります。 なるほど、改行は無いと駄目なんですね。 vbCr,vbLfそれぞれを削除するのではなく、%付きのコードにして送ってやるといけます。 pStr = Replace(Replace(Replace(fileContent, vbCr, "%0D"), vbLf, "%0A"), " ", "%20") > fileContent = Replace のコード位置は、以下で間違いないでしょうか ? その下に fileName = Dir があれば間違いないと思います。

NuboChan
質問者

お礼

ありがとうございます。 教えてもらったコードに変更に変更して、  行数の少ないサンプル(1-10)では、うまく処理できたので行数の多い3つのサンプルでTest()を試してみました。 ① サンプル数 14 ② サンプル数 17 ③ サンプル数 20 ’------------------------------------------------- fileContent = Replace(fileContent, "%", "%25") fileContent = Replace(fileContent, "#", "%23") fileContent = Replace(fileContent, "/", "%EF%BC%8F") fileName = Dir pStr = Replace(Replace(Replace(fileContent, vbCr, "%0D"), vbLf, "%0A"), " ", "%20") ’------------------------------------------------- 結果、以下参考画像のように 不思議な結果になりました。 参考画像 https://imgur.com/rqbRBht  (test()経由でのDeepLの翻訳結果) ④ サンプル数 14 では、翻訳された ⑤ サンプル数 17 では、13-17 が 翻訳されない ⑥ サンプル数 20 では、13-17 が 翻訳されない https://imgur.com/CEIbJlR  (この参考画像は、同じサンプルで直接DeppLで翻訳した場合、test()の場合と微妙に違う結果) 10までは翻訳されていますが ① サンプル数 14 では、11-13 が 翻訳されないが 14 は、翻訳された ② サンプル数 17 では、11-16 が 翻訳されないが 17 は、翻訳された ③ サンプル数 20 では、11-20 が 翻訳されない    (①、②のパターンからでは、20は翻訳されると思いましが翻訳されなかった) 翻訳される場合とされない場合の差がどこにあるのか ? なんだか良くわからない結果になりました。

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.24

> print #2, newText #2のファイルがどこにあるのか見えません。 Replaceすればいいだけじゃないですか。「/」はコード指定にしても駄目っぽいのでとりあえず全角に(UTF-8のコード) 「%」は必ず一番最初に置換 fileContent = Replace(fileContent, "%", "%25") fileContent = Replace(fileContent, "#", "%23") fileContent = Replace(fileContent, "/", "%EF%BC%8F") pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20") ASCIIコード表 https://e-words.jp/p/r-ascii.html

NuboChan
質問者

お礼

>#2のファイルがどこにあるのか見えません。 AI処理を参考にしましたが、付け焼刃はダメですね。 >Replaceすればいいだけじゃないですか。 今回から、実DATAの短縮ミニ版のテキストを利用してテストを始まました。 TEST()マクロで直接文字列をReplace関数で処理すれば良いとのアドバイスでコードを書き換えて実行しました。 結果は、思ったような結果になりません。 改行コードが無くなるのか? 翻訳が1行に結合された結果になります。 (これは、replace関数のコードを記入した場合も、無い場合も同じ結果でした。) 以下の参考画像を参照ください。 https://imgur.com/EsymXr3 fileContent = Replace のコード位置は、以下で間違いないでしょうか ? (また間違えている可能性があるので確認したいです。) Do While fileName <> "" Open folderPath & fileName For Input As #1 '変更(No22) fileContent = "" Do While Not EOF(1) Tmp = Input(1, #1) fileContent = fileContent & Tmp Loop Close #1 fileContent = Replace(fileContent, "%", "%25") fileContent = Replace(fileContent, "#", "%23") fileContent = Replace(fileContent, "/", "%EF%BC%8F") pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20") WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.23

No.21のお礼のコードよく見てなかったのですが 何故に pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20") WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr この2行の位置が変わってるのですか。 また、文中に /#があればそれ以降は無視されます。 %があれば全文翻訳画面になにも表示されません。 Replaceで何かに変換してください。 あとはこちらのデータを参考にして調べてください。 URLで使用できる文字、使用できない文字 https://www.petitmonte.com/internet_blog/url_usecharacter.html

NuboChan
質問者

お礼

全く、今回も初歩的なミスで時間を費やしてしまいお詫び申し上げます。 >何故にこの2行の位置が変わってるのですか。 多分、No21のコードの訂正時にコピペミスをしたのだと思います。 2つのコードを正規の位置に戻してダミーDATAで正常に処理されるのを確認しました。 ダミーDATAで正常に処理されたので実DATAで翻訳する前に アドバイスにあったダメ文字(/#%)が存在するか?チェックするコードを作成して チェックすると複数存在するのを確認しました。 次にダメ文字を半角スペースに変換する下記コードを作成してみましたが 今度のコードは、下記エラーが発生しました。 print #2, newText 実行エラー 52  ファイル名または番号が不正です。 コードの不備をアドバイスをお願いします。 「使用できる文字、使用できない文字」のURLを見ると 今回ダメ文字と指定した以外にも候補に上げなければいけないと思われる文字列(記号)が記載されていますが 数が多いので今回は、とりあえず3文字をターゲットにしました。 Sub ダメ文字を半角スペースに変換() Dim myFolder As String Dim myFile As String Dim text As String Dim newText As String Dim myExtension As String Dim i As Long Dim j As Long Dim k As Long Dim arr As Variant '指定のフォルダを設定 myFolder = "C:\Users\TAC_\DeskTop\test\" '指定の拡張子を設定 myExtension = "*.txt" '指定の文字列を設定 arr = Array("/", "%", "#") '指定フォルダ内のすべてのファイルを処理 myFile = Dir(myFolder & myExtension) Do While myFile <> "" 'ファイルを開く Open myFolder & myFile For Input As #1 'ファイルの内容を読み込む Do Until EOF(1) Line Input #1, text newText = "" '文字列を検索して置換する For i = 1 To Len(text) For j = 0 To UBound(arr) If Mid(text, i, 3) = arr(j) Then newText = newText & " " i = i + 2 Exit For End If Next j If i <= Len(text) Then newText = newText & Mid(text, i, 1) End If Next i '置換後の文字列をファイルに書き込む Print #2, newText Loop 'ファイルを閉じる Close #1 Close #2 '元のファイルを削除 Kill myFolder & myFile '置換後のファイルを元のファイル名で保存 Name myFolder & "temp.txt" As myFolder & myFile '次のファイルを処理 myFile = Dir Loop MsgBox "ダメ文字の半角スペースへの変換が終了しました。" End Sub

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.22

fileContent = Input$(LOF(1), 1) のところを一行ずつ読み込みに変更してみてください。 fileContent = "" Do While Not EOF(1) Tmp = Input(1, #1) fileContent = fileContent & Tmp Loop あとは、ファイルをそれぞれ単体で実行して、DeepLが開かないファイルを限定して ファイルの中身の状態、うまくいくファイルとの比較 その時の fileContent と pStr の内容がどうなっているのか確認しないと、こちらでは問題がないので原因が分かりません。

NuboChan
質問者

お礼

No22によるアドバイスでコードを修正しました。 エラー「ファイルにこれ以上データがありません。」は出なくなりました。 DeepL(画面)は開かないことはありませんが、 DeepL画面の左側に何も読み込まれていないので  右側の翻訳画面にも何も表示されない状態で以前と変化はありません。 kkkkkmさんの環境では、問題なく作動しているとの事なので 私の環境だけの問題化も知れません。 https://imgur.com/PAeiWlb で示した同じテキストファイルを利用して コードをF8でステップ実行した動画(一部編集あり)のURLを添付いたします。 fileContentはdo文で随時読み込まれているようですが Pstrはずっと""のままで変化がありません。 お手数をおかけしますが、以下の動画を見て何かわかる事はありますか ? 動画のダウンロードは、以下のURLの中ほどある動画(2:24)が参考になると思います https://gigafile.ltd/gigafile-howto/ UPした動画のURL(アクセス用) https://21.gigafile.nu/0609-d817d6293422d04c55f86bc174961a914

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.21

No.20の訂正です。 pStr = Replace(Replace(Replace(Replace(fileContent, vbCrLf, ""), vbCr, ""), vbLf, ""), " ", "%20") は pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20") でいいと思います。後から単純にvbCrを追加したので「vbCrLf」と「vbCr&vbLf」が重複するのが頭から抜けてました。

NuboChan
質問者

お礼

コードの修正ありがとうございます。 (回答20から21へのコード修正を反映済みです) 実DATAは、ファイル数が10以上あるので数が少ないダミーDATAで試してみました。 参考画像は、2つのテキストファイル(それぞれをテキストエディターに読み込んで開いた状態を合成) Test()を実行すると、DeepL画面が切り替わっても  DeepL画面の左側に何も読み込まれていないので右側の翻訳画面にも何も表示されない状態で以前と変化はありません。 以下のコードで fileContent = Input$(LOF(1), 1) エラーがでました。  実行じエラー 62  ファイルにこれ以上データがありません。 エラーは、001_textを読み込んで何も翻訳されず、「次の翻訳」でOKをクリックした後で発生。 添付画像のローカルウインドウを参照ください。  fileName 002_text.txt fileContent : "Pink Floyd are an English rock band formed in London in 1965. --------- (続く)  i=0 素人考えでは、002_text.txtを読みだす直前でエラーが発生しているようです。 Sub Test() Dim folderPath As String Dim fileName As String Dim fileContent As String Dim WSH Dim i As Long Dim pStr As String Set WSH = CreateObject("Wscript.Shell") folderPath = "C:\Users\TAC_\DeskTop\test\" fileName = Dir(folderPath & "*.txt") pStr = Replace(Replace(Replace(fileContent, vbCr, ""), vbLf, ""), " ", "%20") WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr Do While fileName <> "" Open folderPath & fileName For Input As #1 fileContent = Input$(LOF(1), 1) Close #1 fileName = Dir If fileName <> "" Then If MsgBox("次の翻訳", vbOKCancel, vbQuestion) = vbCancel Then Exit Do End If Else MsgBox "終了", vbInformation End If Loop Set WSH = Nothing End Sub

NuboChan
質問者

補足

すいません。 参考画像を添付するのを忘れました。 以下が参考画像です。 https://imgur.com/PAeiWlb

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.20

セルの中の改行はLfのまま出力されて、セルと次のセルの間はCrLfで出力されるのでファイルの中で両方が混在してました。 改行をURLに付けるとよくないと思って、外すようにしたのですが、私の環境だと改行があってもDeepLは開いたので気が付きませんでした。 古いマック(多分そのデータは扱わないと思うのですが)ではCrが改行みたいなので、それも入れておきました。 Dim pStr As String を追加して pStr = Replace(Replace(Replace(Replace(fileContent, vbCrLf, ""), vbCr, ""), vbLf, ""), " ", "%20") WSH.Run "https://www.deepl.com/translator#en/ja/" & pStr にしてみてください。 Replaceがくどいですが、一括で指定できる方法があるのかないのか、未調査です。

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.19

> この表示が出なくなるようにコードを修正したいのですがお願いできますか  確認メッセージを非表示にする(DisplayAlertsプロパティ) https://www.moug.net/tech/exvba/0150081.html でどうでしょうか。 また、直接テキストファイルを開いてその内容を翻訳させるというのはいかがですか。 なお、テキストファイルを開いてデータを取得するところは、以前NuboChanさんが「AIさんに回答を求めた結果」と回答したコードからいただきました。 Sub Test() Dim folderPath As String Dim fileName As String Dim fileContent As String Dim WSH Set WSH = CreateObject("Wscript.Shell") folderPath = "C:\Ok\test\test\" fileName = Dir(folderPath & "*.txt") Do While fileName <> "" Open folderPath & fileName For Input As #1 fileContent = Input$(LOF(1), 1) Close #1 WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Replace(fileContent, vbCrLf, ""), " ", "%20") fileName = Dir If fileName <> "" Then If MsgBox("次の翻訳", vbOKCancel, vbQuestion) = vbCancel Then Exit Do End If Else MsgBox "終了", vbInformation End If Loop Set WSH = Nothing End Sub

NuboChan
質問者

お礼

アドバイス感謝します。 LoadFilesToSheets()にアドバイスにあるDisplayAlertsプロパティを利用すべくコードに追加しましたが、 以下の表示は、依然として出現します。 「このブックには、安全でない可能性のある外部ソースへのリンクが一つ以上含まれます。  リンクを信頼できる場合、リンクを更新して最新データを取り込みます。信頼できない場合は、データをそのまま手元で処理してかまいません。」 但し、以前は上記の次に出現していた不要な注意書きらしき表示は出なくなりました。 読み込むファイルが多いとシートを追加するところで 感覚的には「うねうね」とシート追加画面が消えたり出現したりして気持ちが悪いので アドバイスにある「直接テキストファイルを開いてその内容を翻訳させる」ように変更したいと思います。 つまり、LoadFilesToSheets()の開発は停止したいと思います。 '--------------------------------------------------------- 直接テキストファイルを開いてその内容を翻訳させる為に  No19のtest()を実行しましたが   fileNameに以前のコードで作成済みの分割された最初のテキストファイル名が指定されているのがローカルウインドウで確認済みですが   画面が切り替わっても   DeepL画面の左側に何も読み込まれていないので右側の翻訳画面にも何も表示されていません。 多分原因は、以下のコードが原因だと思うのですが ? WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Replace(fileContent, vbCrLf, ""), " ", "%20") ファイル内のテキストファイルには、改行されたセルがあるのでNO18のように変更する必要があると思われます。 (でも、コードにはvbCrLfの表記があるので改行対策済みのコードだとも考えられるし.... ????) そうではなく他に問題があるのでしょうか ? Sub LoadFilesToSheets() Dim folderPath As String Dim fileName As String Dim wb As Workbook Dim ws As Worksheet folderPath = "C:\Users\TAC_\DeskTop\test\" '***は伏字 fileName = Dir(folderPath & "*.*") Application.DisplayAlerts = False Do While fileName <> "" Set wb = Workbooks.Open(folderPath & fileName) Set ws = ThisWorkbook.Sheets.Add(After:= _ ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.Name = fileName wb.Sheets(1).UsedRange.Copy ws.Range("A1") wb.Close False fileName = Dir Loop Application.DisplayAlerts = True End Sub

  • kkkkkm
  • ベストアンサー率64% (1478/2291)
回答No.18

英文が改行有だったりする場合(セルにある場合)は WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Cells(i, "A"), " ", "%20") を WSH.Run "https://www.deepl.com/translator#en/ja/" & Replace(Replace(Cells(i, "A").Value, vbLf, ""), " ", "%20")

NuboChan
質問者

お礼

kkkkkmさん、見捨てないで善後策を見出していただきありがとうございます。 No17,No18のコードを私なりに利用できる方法として 総文字数が4000文字で塗分けしてテキストファイルに分割して出力しているので これをシートに読み込んでNo17(18)のコードを利用してDeepLに翻訳させればかなり手抜きができると思います。 (最終な翻訳の結果はコピペで保存する手間は必要ですが.....) そこで  指定フォルダー内のファイルを  現在のブックにファイル名をシート名にして新しく読み込んで行くマクロを以下のように作成しましたが 不備があるのか、以下の表示が出ます。 (この表示以外にも続けて不要な注意らしき表示が出ます。) 「このブックには、安全でない可能性のある外部ソースへのリンクが一つ以上含まれます。  リンクを信頼できる場合、リンクを更新して最新データを取り込みます。信頼できない場合は、データをそのまま手元で処理してかまいません。」 この表示が出なくなるようにコードを修正したいのですがお願いできますか ? Sub LoadFilesToSheets() Dim folderPath As String Dim fileName As String Dim wb As Workbook Dim ws As Worksheet folderPath = "C:\Users\***\DeskTop\test\"  '***は伏字 fileName = Dir(folderPath & "*.*") Do While fileName <> "" Set wb = Workbooks.Open(folderPath & fileName) Set ws = ThisWorkbook.Sheets.Add(After:= _ ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.Name = fileName wb.Sheets(1).UsedRange.Copy ws.Range("A1") wb.Close False fileName = Dir Loop End Sub

関連するQ&A

  • エクセルVBAにてテキスト出力がうまくいきません

    エクセルシートの1列に以下のような文字列を打ち込みました。 - a aa aaa aaaa aaaaa - b bb bbb bbbb bbbbb - c cc ccc cccc ccccc - 「-」の2行後をテキストを出力した際のファイル名とし、ファイル名を含んだ次の「-」までの文字列をそのテキストの中に出力したいです。なお、全体の行数は分かっています。 例えば上の文字列に対して実行すると、 a.txt b.txt c.txt というファイルができ、それぞれの中には a aa aaa aaaa aaaaa などがそれぞれ出力されるようにしたいです。 Sub tepa() Dim strFilename As String Dim FileNumber As Integer Dim strREC As String j = 1 For i = 1 To 70 If Cells(i, 1) = "-" Then strFilename = Cells(i + 2, 1) & ".txt" Do While Cells(i + j, 1) <> "-" If i > 70 Then Exit Sub End If FileNumber = FreeFile strREC = Cells(i + j, 1) Open strFilename For Append As FileNumber Print #FileNumber, strREC Close j = j + 1 Loop End If i = i + j Next End Sub さきほど初めてVBAなるものを知り、見よう見まねで書いてみましたが・・・ループに陥ったりテキストファイルが1つめしか出力されなかったりとうまくいきません。 改善点など教えていただけたら嬉しいです。 よろしくお願いします。

  • EXCELVBAでデータをテキストファイルで出力したいと

    EXCELVBAでデータをテキストファイルで出力したいと考えています。 ***************************** 作成したVBA ***************************** Sub test_Click() Dim fNAME As String fNAME = "c:\test.txt" Open fNAME For Output As #1 i = 1 Print #1, "<test=" & Cells(1, i) & "," & Cells(2, i) & "," & Cells(3, i) & "," & Cells(4, i) & "," & Cells(5, i) & ">" Close #1 '閉じる End Sub ***************************** エクセルの値 ***************************** A列 1 2 3 4 5 ***************************** 出力されたテキストファイル ***************************** <test=1,2,3,4,5> このようになっていますが、 エクセルが A列 1 2 のように、2個しかないと、 <test=1,2,,,> のようになってしまいます。 <test=1,2> ↑のようになるように、エクセルの値に応じて、 「,」が出力しないようにしたいです。 どうしたらよいのでしょうか。 よろしくおねがいします。

  • 【VBA】"オブジェクトが必要です"メッセージ出力

    VBAを使用し、A列に日付、B列に数量、C列に単価、D列に金額を入力し、 数量*単価にて、金額を求めるVBAを作成しています。 そこまでは上手くいくのですが、D列で求めた金額を最終行で合計する事で 躓いてしまっています。 行は常に追加され可変の為、最終行を「Cells(Row.Count, 1).End(xlUp).Row」 にて引っ張ってこようと思っております。以下のようなVBAを記載しましたが、 「オブジェクトが必要です」とのメッセージがでて、処理が上手くいきません。 どのような問題があるのか、お分かりの方、ご回答頂けますと幸いです。 ■環境  Windows7  Excel2010 ■VBA Sub test() Dim i As Long Dim j As Long Dim k As Long For i = 2 To Cells(Row.Count, 1).End(xlUp).Row Cells(i, 4) = Cells(i, 2) * Cells(i, 3) Next j = Cells(Row.Count, 1).End(xlUp).Row + 1 k = Cells(j, 1).End(xlUp).Row Cells(j, 4) = WorksheetFunction.Sum(Cells(2, 4), Cells(k, 4)) End Sub

  • VBAで文字列のカウントがうまくいかない・・・です

    Dim cnt As Long Dim i As Long Dim lastRow As Long For i = 1 to 20 step 2 lastRow = Cells(65536, i).End(xlUP).Row cnt = WorksheetFunction.CountIf(ActiveSheet.Range(Cells(10, i),Cells(lastRow, i), "お世話になっております")cnt = cnt + cnt Next Excelのセルを1列ずつ飛ばして列に「お世話になっております」が含まれたら件数をカウントしています。 そのカウント数が何故かリセットされてしまいます。 カウント数を足していきたいのですが・・・考え方自体が違うのでしょうか?

  • VBAでDateaddの日付計算で困っていることがあるので助けていただけないでしょうか。よろしくお願いします。

    シート: A列には”注射”という文字を入れるようにします。 B列には1月1日から12月31日まで入っています。 C列はB列の90日後を入れるようにします。 D列はC列の3日前を入れます。・・・としたいのですがその3日の間A列に”注射”が入っていたらその日を入れずに3日前にしたいのです。 稼働日みたいな感じでしょうか・・・・ どうしたらよいでしょうか?お願いします。 例えば、B列の「1月1日」の90日後はC列「3月31日」でD列は通常「3月28日」が入っていますがB列「3月30日」の左のA列に”注射”があったらそこを無視して「3月27日」と入れたいのです。 Sub count() Dim i As Long Dim lastrow As Long lastrow = Range("B1").End(xlDown).Row For i = 1 To lastrow Cells(i, 3).Value = DateAdd("d", 90, Cells(i, 2).Value) Next For i = 1 To lastrow Cells(i, 4).Value = DateAdd("d", -3, Cells(i, 3).Value) Next End Sub 説明が下手なのでもしよかったら実際作ったものを見ていただいた方が分かるかもしれません。 http://briefcase.yahoo.co.jp/bc/robert_kubica_bmw/vwp2?.tok=bcf8oGbB4FXgt88k&.dir=/&.dnm=1count.xls&.src=bc

  • Excel VBAで文字列の部分一致の文字列を表示

    以前、こちらで頭5文字までの一致で文字列を表示するVBAを教えて頂きました。今回はFINDなどの部分一致での文字列を表示することをしたいのですが、ご教示いただけますと幸いです。 下記はSheet1のA3に文字を5文字以内いれるとSheet2のC列からピックアップしてSheet1のA列に文字列を表示する及びSheet2のB列のデータをSheet1のC列に表示させるVBAです。 Sub Test2() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim SData As String, i As Long, VRet As Variant Dim c As Range, LastRow As Long Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") SData = CStr(Ws1.Range("A3").Value) If SData = "" Then Exit Sub i = 5 LastRow = Ws1.Cells(Rows.Count, "A").End(xlUp).Row If LastRow < i Then LastRow = i End If Ws1.Range(Ws1.Cells(i, "A"), Ws1.Cells(LastRow, "C")).ClearContents With Ws2 For Each c In .Range(.Cells(1, "C"), .Cells(Rows.Count, "C").End(xlUp)) VRet = InStr(1, CStr(c.Value), SData, vbTextCompare) If VRet = 1 And Len(c.Value) >= 10 Then Ws1.Cells(i, "A").Resize(1, 2).Value = c.Resize(1, 2).Value 'とりあえずSheet2のB列のデータ(C列のデータに同期したデータ)をSheet1のC列に Ws1.Cells(i, "C").Value = .Cells(c.Row, "B").Value i = i + 1 End If Next End With End Sub 宜しくお願い致します。

  • VBAデータ元から新規ブックに出力

    現在のブック内に出力されるとメモリの都合上時間がかかりすぎますそこで新規ブック1個に出力する構文を教えていただきたいのですが、宜しくお願いします。 Sub 1111() Dim c As Range Dim i As Integer, LastRow As Long Dim NewSheetName As String, MatchFlag As Boolean Application.ScreenUpdating = False NewSheetName = "" With Sheets("データ元") For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp)) MatchFlag = False If NewSheetName <> Year(c.Value2) & "年" & Month(c.Value2) & "月" Then NewSheetName = Year(c.Value2) & "年" & Month(c.Value2) & "月" For i = 1 To Worksheets.Count If Sheets(i).Name = NewSheetName Then Sheets(i).Cells.ClearContents MatchFlag = True Exit For End If Next i If MatchFlag = False Then Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = NewSheetName End If End If LastRow = Sheets(NewSheetName).Cells(Rows.Count, "A").End(xlUp).Row Sheets(NewSheetName).Cells(LastRow + 1, "A").Resize(1, 6).Value = .Cells(c.Row, "A").Resize(1, 6).Value Sheets(NewSheetName).Columns("A:F").EntireColumn.AutoFit '↑A列からF列まで自動幅調整してます Next .Activate End With Application.ScreenUpdating = True MsgBox "終了しました", vbInformation End Sub

  • エクセル VBA テキストデータ書きだし

    お世話になっております。 エクセルのデータに記入したデータをテキストに書き出したいのですが、検索した結果、 A列だけテキスト化には成功したのですが、複数列(A-U)までコピーしたいのです。 シート名"メール" テキスト名"テキスト" 申し訳ございませんが、よろしくお願いします。 Sub テキスト() Dim StrFN As String StrFN = ActiveWorkbook.Path & "\テキスト.txt" Dim i As Long, LngLoop As Long Dim IntFlNo As Integer Worksheets("メール").Activate LngLoop = Range("a65536").End(xlUp).Row IntFlNo = FreeFile Open StrFN For Output As #IntFlNo For i = 1 To LngLoop Print #IntFlNo, Cells(i, "A") Next i Close #IntFlNo End Sub

  • マクロ 入力する文字に色を付けたい

    Sub CountUp(ByVal mCol1 As String, mCol2 As String) Dim LastRow1 As Long Dim LastRow2 As Long Dim mRow As Long With Sheets("プレーヤー") LastRow1 = .Cells(Rows.Count, mCol1).End(xlUp).Row LastRow2 = .Cells(Rows.Count, mCol2).End(xlUp).Row If LastRow1 > LastRow2 Then mRow = LastRow1 Else mRow = LastRow2 End If If LastRow1 = 1 Then LastRow1 = 2 End If .Cells(mRow + 1, mCol1).Value = .Cells(LastRow1, mCol1) + 1 End With End Sub このコードに文字の色の指定をしたいです Selection.Font.ColorIndex = 3を入れたら赤色文字で入力できるかなと思ったのですがうまくいきませんでした(エラーにはならないのですが、色が付かなかったです)

  • msgboxの表示

    A列の値とC列の値をMsgboxに表示するにはどうしたらいいのでしょうか?C列で一番高い商品とその品名A列を表示させたいのですが・・ Sub hinmei() Dim i As Long For i = 2 To Range("C65535").End(xlUp).Row Dim x As Long Dim a As Long x = Cells(i + 1, 5) If Cells(i, 5).Value < x Then a = x End If Next MsgBox a End Sub