vb6でエクセルアドレスを取得する方法

このQ&Aのポイント
  • VB6でプログラムを作成して、特定の文字が含まれるセルのアドレスを取得する方法について教えてください。
  • 現在、VB6でエクセルオブジェクトを作成し、特定の文字が含まれるセルを抽出しています。ただし、アドレスを取得する部分でエラーが発生しています。
  • エラーが発生している部分のコードを次に示します。tb(b) = xlsオブジェクト.Worksheets(1).cells(a,1).adress 正常にアドレスを取得するための方法を教えてください。
回答を見る
  • ベストアンサー

vb6でのエクセルアドレス取得

現在、vb6でプログラムを作成しています。 エクセルオブジェクトを作成し、ある特定の文字がはいっているセルを 抽出し、上の行から順にアドレスを返すプログラムを作っています。 ***************** dim tb() as string For a= 1 To 行の末 If 0 <> InStr(xlsオブジェクト.Worksheets(1).Cells(a,1).Value, "特定の文字") Then If b = 1 Then ReDim tb(1) Else b = b + 1 ReDim Preserve tb(b) End If tb(b) = xlsオブジェクト.Worksheets(1).cells(a,1).adress End if Next ***************** これで行うと、「tb(b) = xlsオブジェクト.Worksheets(1).cells(a,1).adress」の部分で、正常に結果が返らずエラーとなります。 もし、分かるようでしたらご教授いただきたいです。 よろしくお願いします。

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

  • ベストアンサー
  • redfox63
  • ベストアンサー率71% (1325/1856)
回答No.1

どのようなエラーがでるのかを明記したほうがいいでしょう そのエラーが出る際の元データもあるとより的確な解答がつくかも知れません xlsオブジェクトからすべて指示するのは冗長だともいます 今回セルのデータが対象なので Rangeオブジェクトでよさそうですが・・・ dim rng as Range, ss as String For a= 1 To 行の末   set rng = xlsオブジェクト.Worksheets(1).Cells(a,1)   ss = rng.Value   If 0 <> InStr(ss, "特定の文字") Then     If b = 1 Then       ReDim tb(1)     Else       b = b + 1       ReDim Preserve tb(b)     End If     tb(b) = rng.adress   End if Next といった具合で ・・・ Findで探すといった方法も検討してもいいかも ・・・

tamahome10
質問者

お礼

あ・・・ 今回初めてvbでプログラム作成する為、 rangeオブジェクトのことは、考え付きませんでした。 とても参考になりました。 サンプル付きでとても感謝しています。 ありがとうございました。

その他の回答 (1)

回答No.2

示されたコードが全てならば、変数bは最初0です。ですから >If b = 1 Then >ReDim tb(1) よりも >Else >b = b + 1 >ReDim Preserve tb(b) が、先に実行されます。 この段階で配列tbは宣言されただけでまだReDimされていません。それをPreserveしようとしてエラーになっていると考えられます。 最初からステップ実行を行えば、エラーの原因はすぐにわかったはずです。 Option Explicitは宣言する癖を付けておいた方がいいです。 また、tb(0)の値を使わないようですが、それならOption Baseは1に設定した方がいいと思います。 IFのネストが煩わしい場合は ReDim tb(1) For a= 1 To 行の末 If 0 <> InStr(xlsオブジェクト.Worksheets(1).Cells(a,1).Value, "特定の文字") Then b = b + 1 ReDim Preserve tb(b) tb(b) = xlsオブジェクト.Worksheets(1).cells(a,1).adress End if Next とした方がすっきりします。

tamahome10
質問者

お礼

ご回答ありがとうございました。 変数制限が足りず、すみませんでした。 if文も含め参考にしたいと思います。

関連するQ&A

  • ExcelのVBAでシート選択・最終行取得がうまくいかない。

    シートA・Bがあり、シートAの変数markが★だったら、シートBへいき、最終行を取得、ということをしたくて以下のようなコードをかきました。 Worksheets("A").Select Last3 = Cells(6).CurrentRegion.Rows.Count Worksheets("B").Select Last1 = Cells(6).CurrentRegion.Rows.Count For w = 1 To Last1 Worksheets("B").Select Mark = Cells(w, 26) If Mark = "★" Then Sheets("A").Select Last3 = Cells(6).CurrentRegion.Rows.Count MsgBox Last3 End If Next ですが、シートAの最終行が表示されます。 どこがちがうのでしょうか?

  • EXCEL VBA 取得したセルの列の最終行

    お客さんからいただいたEXCELフォーマットに沿って、集計ツールを作成していますが 下記でつまってしまいました。 Wb.Worksheets("Sheet1").Cells.Find("実施日").Select Sel_Col = Selection.Column Last_Row = Wb.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row ※1 For i = Last_Row To 2 Step -1 If Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Value = Day Then ※2 If Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Offset(-5).Value = "A" Then A_count = A_count + 1 ElseIf Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Offset(-5).Value = "B" Then B_count = B_count + 1 ElseIf Wb.Worksheets("Sheet1").Cells(Sel_Col, i).Offset(-5).Value = "C" Then C_count = C_count + 1 End If Else End If Next i まず※1の箇所ですが、Sheet1の実施日と入力されているセルの列番号を取得して その列の最終行を取得したいのですが、上記作成したものですと入力されている列全部の 中での最終行が取得されてしまいます。 この場合、Sel_Col をどのように使えばよろしいでしょうか? 次に※2ですが、※1で取得した列の最終行から1つずつ上に上がりながら 日付が今日であれば、そのセルから5つ左のセルのA、B、Cいずれかを カウントするという造りにしたいと思っています。 実行すると1004エラーでアプリケーション定義、オブジェクト定義のエラーと 出てしまいます。 Wbはset Wbとして開いたブックを定義しています。 DayはDay = Dateで今日の日付を取得しています。 独学で無茶苦茶なコードですが、 どなたか詳しい方、ご教示お願いいたします。

  • エクセル

    前回質問させていただきました件の続になります。 大まかにうまく行きそうですが、一部 ¥0の部分が入っている行を削除したいのですが、うまくいきません。 データはA~Eに入力されていて、B列に数字が入っています。 B列が 0の場合その行を削除します。 If Worksheets("Sheet2").Cells(F, 2) = 0 Then '0の場合は行を削除する Cells(F, 1).EntireRow.Delete End If Fは行数をカウントするものです。 お手数ですが、よろしくお願いいたします。

  • VBAで B.xlsの番号と同じ番号がD.xlsにあればくっつけたい

    VBAで B.xlsの番号と同じ番号がD.xlsにあればくっつけたい  エクセル関数でいうとVlookUPをしたいのですが、1004エラーがかかってしまいます。 必要なところだけを抜き取っているので、分かりにくいかと思いますが、   Dim a, b, c, d, y, x, z, i, j, k, m, n, o, r As Long a = 2 '2 なのは、A2から数えるため。 b = 0 'BookBのレコードの数を数えるための変数。 Do While Workbooks("B.xls").Worksheets("Sheet1").Cells(a, 1) <> "" a = a + 1 b = b + 1 Loop Workbooks("B.xls").Activate For k = 2 To b For m = 2 To 300000 エラー⇒ If Workbooks("B.xls").Worksheets("Sheet1").Cells(k, 1) = Workbooks("D.xls").Worksheets("Sheet1").Cells(m, 1) Then Workbooks("B.xls").Worksheets("Sheet1").Cells(k, 12) = Workbooks("D.xls").Worksheets("Sheet1").Cells(m, 2) Workbooks("B.xls").Worksheets("Sheet1").Cells(k, 13) = Workbooks("D.xls").Worksheets("Sheet1").Cells(m, 3) End If Next m Next k   ・   ・   ・ の部分でつまっています><; 説明が不十分でしたら追加いたしますので、初心者の簡単なエラーだとは思うのですが、教えてください<(__)>

  • エクセルのマクロを利用したワードの開き方

    エクセルのマクロを利用したワードの開き方を教えてください。よろしくおねがいします。ちなみにコードは Option Explicit Dim 行, ドライブ, 親フォルダ, 子フォルダ, ファイル名, 拡張子, パス Dim フルパス As String Dim ワード As Object Dim ワード文書 As Object Sub 環境リストボックスでクリックされた() 行 = Worksheets("呼出").Cells(2, 1) + 1 管理表シートから値を取り出す 選択されたファイルを開く End Sub Private Sub 管理表シートから値を取り出す() ドライブ = Worksheets("管理表").Cells(行, 2) 親フォルダ = Worksheets("管理表").Cells(行, 3) 子フォルダ = Worksheets("管理表").Cells(行, 4) ファイル名 = Worksheets("管理表").Cells(行, 5) 拡張子 = Worksheets("管理表").Cells(行, 6) End Sub Private Sub 選択されたファイルを開く() ChDrive ドライブ パス = ドライブ & "\" & 親フォルダ & "\" & 子フォルダ ChDir "C:\ときめき\環境" If 拡張子 = "xls" Then Workbooks.Open Filename:=ファイル名 & ".xls", ReadOnly:=True ElseIf 拡張子 = "doc" Then フルパス = パス & "\" & ファイル名 & ".doc" 'フルパスを作成 Set ワード = CreateObject("Word.Application") 'Wordを起動する ワード.Visible = True 'Wordを表示する Set ワード文書 = ワード.documents.Open(フルパス) 'Word文書を開く End If End Sub となっています。 あと、OSはwindowsMeで ソフトはエクセル、ワード共に2000を利用しています。 よろしくおねがいします。

  • エクセルのマクロについて

    お手数ですが誰か教えてください! BのデーターをAに集計するマクロを作ったのですが 処理速度とっても遅いのです。 高速で処理する方法はありませんでしょうか? 私が作ったマクロ Sub 集計() Dim Z As Integer Dim i As Integer Dim X As Integer For Z = 2 To 2000 For i = 2 To 2000 For X = 3 To 20 If Worksheets("A").cells(Z, 1) = Worksheets("B").cells(i, 1) And       Worksheets("A").cells(1, X) = Worksheets("B").cells(i, 14) Then Worksheets("A").cells(Z, X) = Worksheets("B").cells(i, 16) End If Next X Next i Next Z End Sub       どこかが間違っている気がしますがマクロ初心者のため       先に進めません。       どうかご教授よろしくお願い致します。

  • エクセルマクロ 検索して値を取得

    マクロはよく分かっていません。 既存のVBAを見ながらマネしてる状態なので、どこが間違っているのか教えて下さい。 sheet1 A 所属 1 789         2     3 sheet2    A     B 所属コード  所属 1 12345    あいう123 2 12346    あいう456   3 12347    あいう789 やりたいこと シート1の所属が「789」だったらとシート2の所属から「あいう789」を検索し、シート2の所属コード「12347」をシート1の所属に返す。 私が作ったやつだと「12347」は1行目でなく、3行目に返ってしまいます。 Dim SyozokuRange as Range Dim Syozoku as String Dim Buf as String Buf = "あいう" Syozoku = Buf & Syozoku Set SyozokuRange = worksheets(2).range("a:b").currentregion For i = 1 to SyozokuRange.rows.count If Syozoku = SyozokuRange.cells(i,2) Then worksheets(1).cells(i,1).value = SyozokuRange.cells(i,1) end if next i

  • Excel VBA ExecuteExcel4Macroについて

    こんにちは。よろしくお願いします。 あるフォルダ"D:\test"のなかに、4つのxlsファイル"o.xls"、"a.xls"、"b.xls"、"c.xls"があるとします。 使用するシート名は、それぞれo,a,b,c(ファイル名から".xls"を除いたもの)とします。 このとき"o.xls"を開いて、下記のマクロを実行すると、1行目にパス名、2行名にファイル名、3行目以下に(1列目は"a.xls"の、2列目は"b.xls"の、3列目は"c.xls"の)セルA3以下が読み込まれます。 たとえば、結果は添付の図のようになります。図がうまくアップできなかったらごめんなさい。 Sub sample1() Application.Calculation = xlManual Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next Worksheets("o").Cells.Clear Dim p As String, fn As String, fc As Long, i As Long, j As Long, d, e p = ActiveWorkbook.Path fn = Dir(p & "\" & "*.xls", 0) fc = 0 If fn <> "" Then fc = fc + 1 For j = 3 To 6 With Worksheets("o") .Cells(1, fc).Value = p & "\" & fn .Cells(2, fc).Value = fn d = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & j & "C1") If d = 0 Or IsError(d) Then Exit For Else .Cells(j, fc) = d End If End With Next j End If Do fn = Dir() If fn <> "" Then fc = fc + 1 For i = 3 To 6 With Worksheets("o") .Cells(1, fc).Value = p & "\" & fn .Cells(2, fc).Value = fn e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1") If e = 0 Or IsError(d) Then Exit For Else .Cells(i, fc) = e End If End With Next i Else Exit Do End If Loop Application.ScreenUpdating = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic End Sub 上記の例は変数iとjが3から6までしか動きませんし、読み込むxlsファイルも3つしかありませんのですぐに終わりますが、実際には行やファイルがもっとたくさんあり、非常に時間がかかっています。そこで、 ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1") を e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R3C1:R6C1") というような風にして、For~Nextも使用せず .range(Cells(3, fc),cells(6, fc)) = e というふうに範囲で読み込もうとしたのですがうまくいきません。 ExecuteExcel4Macroは範囲を読み込むことはできないのでしょうか? 何とかして処理速度を上げたいのですが、どうすればよいでしょうか。

  • エクセルVBAで、分岐がうまくできません。

    A,B,,Cのりんごとみかんの3種類の仕入れパターンがあり仕入の数量を算出したいですが、適正値が算出されません。 どのようにしたら、適正値を算出できるにのか教えてください。 Sub test() Dim i As Integer 'A リンゴは、500以下になったら1000個になるように仕入 'A みかんは、500以下になったら1000個になるように仕入 'A みかんまたはりんごの片方が500以下になったらみかんとりんごを1000個になるように仕入 i = 2 Do While Worksheets("sheet1").Cells(i, 1) <> "" If Cells(i, 1) = "A" And Cells(i, 2) <= 500 Or Cells(i, 3) <= 500 Then Worksheets("sheet1").Cells(i, 4) = 1000 - Cells(i, 2) Worksheets("sheet1").Cells(i, 5) = 1000 - Cells(i, 3) 'End If 'i = i + 1 'Loop 'B リンゴは、400以下になったら2000個になるように仕入 'B みかんは、400以下になったら2000個になるように仕入 'A みかんまたはりんごの片方が400以下になったらみかんとりんごを2000個になるように仕入 i = 2 'Do While Worksheets("sheet1").Cells(i, 1) <> "" ElseIf Cells(i, 1) = "B" And Cells(i, 2) <= 400 Or Cells(i, 3) <= 400 Then Worksheets("sheet1").Cells(i, 4) = 2000 - Cells(i, 2) Worksheets("sheet1").Cells(i, 5) = 2000 - Cells(i, 3) 'End If 'i = i + 1 'Loop ''C リンゴは、300以下になったら3000個になるように仕入 ''C みかんは、300以下になったら3000個になるように仕入 'A みかんまたはりんごの片方が300以下になったらみかんとりんごを3000個になるように仕入 i = 2 'Do While Worksheets("sheet1").Cells(i, 1) <> "" ElseIf Cells(i, 1) = "C" And Cells(i, 2) <= 300 Or Cells(i, 3) <= 300 Then Worksheets("sheet1").Cells(i, 4) = 3000 - Cells(i, 2) Worksheets("sheet1").Cells(i, 5) = 3000 - Cells(i, 3) End If i = i + 1 Loop End Sub

  • ExcelのVBAでコピーのやり方

    シート1のAL列の3行目以降の中から0以外の 値が入っているAJ列~AN列の行を全てコピーして、 シート2のB列~F列に貼り付けたいです。 シート2のB列~F列の7行目から下にコピーした値を入れていきたく、 値が入っていたらその次の行に貼り付けたいです。 例えば、7行目~15行目まで値が入っていたら、16行目から貼り付けるようにしたいです。↓のように書いてみたのですが、 コピーしている状態になるだけで、シート2の方へ貼り付けができない状態です。 また、オブジェクトが必要ですと表示が出ます。 どこをどうなおしたらいいでしょうか。 文章がわかりにくく申し訳ありません。 回答よろしくお願いいたします。 sub 値をコピー() Dim rTargetRange As Range, ii As Long Set rTargetRange = Nothing For ii = 4 To Cells(Rows.CountLarge, "AL").End(xlUp).Row If (Cells(ii, "AL").Value <> 0) Then If (rTargetRange Is Nothing) Then Set rTargetRange = Cells(ii, "AJ").Resize(, 5) Else Set rTargetRange = Application.Union(rTargetRange, Cells(ii, "AJ").Resize(, 5)) End If End If Next With Worksheets("sheet2") With .Cells(.Rows.CountLarge, "B").End(xlUp) If (.Row = 1 And .Value = "") Then rTargetRange.Copy .Offset(0) Else rTargetRange.Copy .Offset(1) End If End With End With End Sub また、↓のような違ったコードも試しましたが、 うまくいきませんでした。 N=Sheet2.Cells(Rows.CountLarge, "AL").End(xlUp).Row+1 SHEET1.SELECT For ii = 4 To Cells(Rows.CountLarge, "AL").End(xlUp).Row If Cells(ii, "AL").Valu e <> 0 Then RANGE("AJ" & ii & ":AN" & ii).COPY SHEET2.RANGE("B" & N) N=N+1 END IF NEXT

専門家に質問してみよう