VBAでのデータ処理に関する質問
- VBAの特定の構文がうまく実行されていません。エラーメッセージが表示される原因を知りたいです。
- on error resume nextを省略するとオブジェクトが必要ですというエラーメッセージが表示されます。
- VBAのマクロでデータを処理する際にオブジェクトが必要な場合があります。
- ベストアンサー
VBA
以下の構文では、理想通りに実行できません。10行目までは大丈夫なのですが、そのあとは何が悪いのかわかりません。 on error resume nextを省略するとオブジェクトが必要ですとエラーメッセージが表示されます。 回答宜しくお願い致します。 sub macro1() dim a as variant dim h as range dim r as long dim w0 as worksheet set w0 = activesheet worksheets.add after:=w0 r = 1 range("A1:G1") = array("苗字","名前","住所","TEL","〒","好きなスポーツ","性別") on error resume next for each h in w.range("A1:A" & w.range("A65536").end(xlup).row) if h <> "" then a = split(application.trim(replace(replace(h, " "," "),":",":")), " ") r = r + 1 cells(r, "A") = split(a(0), ":")(1) cells(r, "B") = split(a(1), ":")(1) cells(r, "C") = split(a(2), ":")(1) cells(r, "D") = split(a(3), ":")(1) cells(r, "E") = split(a(4), ":")(1) cells(r, "F") = a(5) cells(r, "G") = a(6) end if next end sub
- 8312yuki
- お礼率46% (22/47)
- Excel(エクセル)
- 回答数5
- ありがとう数4
- みんなの回答 (5)
- 専門家の回答
質問者が選んだベストアンサー
以下のようにしましょう。 Sub macro1() Dim a As Variant Dim h As Range Dim r As Long Dim w As Worksheet '追加 Dim w0 As Worksheet 'w0はマクロ呼び出し時のアクティブシート。元データがあるシート Set w0 = ActiveSheet Worksheets.Add after:=w0 'wはデータを作成する、新規作成したシート Set w = ActiveSheet r = 1 '見出しは、新規作成した方のシートに書き込む w.Range("A1:G1") = Array("苗字", "名前", "住所", "TEL", "〒", "好きなスポーツ", "性別") On Error Resume Next '元データは、呼び出し時のアクティブシート、つまりw0のシートから参照する For Each h In w0.Range("A1:A" & w0.Range("A65536").End(xlUp).Row) If h <> "" Then a = Split(Application.Trim(Replace(Replace(h, " ", " "), ":", ":")), " ") r = r + 1 '結果は新規作成した方のシート、つまりwのシートに書き込む w.Cells(r, "A") = Split(a(0), ":")(1) w.Cells(r, "B") = Split(a(1), ":")(1) w.Cells(r, "C") = Split(a(2), ":")(1) w.Cells(r, "D") = Split(a(3), ":")(1) w.Cells(r, "E") = Split(a(4), ":")(1) w.Cells(r, "F") = a(5) w.Cells(r, "G") = a(6) End If Next End Sub
その他の回答 (4)
- chie65535
- ベストアンサー率43% (8524/19375)
>このデータベースを基に、追加したシートのA1からG1に表題を作り、それぞれ分割した文字列を入力するというVBAを希望しております。 では、当方が「回答No.2」で示したVBAプログラムをそのまま使用して下さい。 貴方が想定している通りのデータで、貴方の想定した通りに動作します。
- chie65535
- ベストアンサー率43% (8524/19375)
追記。 当方で修正したマクロを実行すると、添付画像のようになる筈です。 これで問題がある場合は、補足説明で補足して下さい。
補足
早速の回答ありがとうございます。 文字列のデータはA1セルから複数行 名字:山田 名前:太郎 住所:北海道 TEL: 011-##6-3#36 〒:0##-0##5 野球 男 という感じに個人情報が入力されています。 野球と男の前には、空白しかありません。 このデータベースを基に、追加したシートのA1からG1に表題を作り、それぞれ分割した文字列を入力するというVBAを希望しております。 宜しくお願い致します。
- chie65535
- ベストアンサー率43% (8524/19375)
追記。 >何が悪いのかわかりません。 悪いのは「質問者さんが、どこのシートにあるデータを読んで、どこのシートに書き込むのかを、まったく理解してない」と言う点です。
- dogs_cats
- ベストアンサー率38% (278/717)
データがどのような 文字列であるか不明なので回答のしようがありません。 ダミーデータ提示下さい。 "苗字","名前","住所","TEL","〒","好きなスポーツ","性別"のデータがどのように区切りを入れて入力されているのか。 気づいた点は for each h in w.range("A1:A" & w.range("A65536").end(xlup).row)はA2から始めるべきでは? よって、rは2から開始 r=r+1はend ifの前
補足
早速の回答ありがとうございます。 文字列のデータはA1セルから複数行 名字:山田 名前:太郎 住所:北海道 TEL: 011-256-3336 〒:056-0695 野球 男 という感じに個人情報が入力されています。 このデータベースを基に、追加したシートのA1からG1に表題を作り、それぞれ分割した文字列を入力するというVBAを希望しております。 宜しくお願い致します。
関連するQ&A
- 構文の解説をつけてください。
sub macro1() dim a as variant dim h as range dim r as long dim w0 as worksheet set w0 = activesheet worksheets.add after:=w0 r = 1 range("A1:G1") = array("苗字","名前","住所","TEL","〒","好きなスポーツ","性別") on error resume next for each h in w0.range("A1:A" & w0.range("A65536").end(xlup).row) if h <> "" then a = split(replace(application.trim(replace(replace(h, " "," "),":",":")),": ",":"), " ") r = r + 1 cells(r, "A") = split(a(0), ":")(1) cells(r, "B") = split(a(1), ":")(1) cells(r, "C") = split(a(2), ":")(1) cells(r, "D") = split(a(3), ":")(1) cells(r, "E") = split(a(4), ":")(1) cells(r, "F") = a(5) cells(r, "G") = a(6) end if next end sub
- ベストアンサー
- Visual Basic
- VBA case判定で
Excel2010 Win7使用 VBA独学中の初心者です。 下記のcase判定でTrueなのに、Trueと判定してもらえません。 解決策を教えて頂けると助かります。 また、もっとスマートな方法があれば、 併せて教えて頂けると助かります。 例) hの中に"早い"という文字列がある場合 Case InStr(h, "早い") > 0 において、InStr=1が入っている場合でも Trueと判定されず、次のcaseに移行してしまいます。 Sub chg2() Dim r As Long Dim c As Long Dim day As Long Dim dc As Long Dim h As String day = Right(Range("S5"), 2) Select Case day Case 28 dc = 30 Case 29 dc = 31 Case 30 dc = 32 Case 31 dc = 33 End Select For r = 53 To Range("A52").End(xlDown).Row Step 2 For c = 3 To dc h = Cells(r, c) Select Case h Case InStr(h, "早い") > 0 h = Replace(h, "早い", "a") Case InStr(h, "遅い") > 0 h = Replace(h, "遅い", "b") ・ ・ ・ End Select Next c Next r End Sub
- ベストアンサー
- Excel(エクセル)
- EXCEL2010エラーVBA
下記を実行するとエラーになりEXCEL2010が終了してしまいます。 fDebug:0 offset00009391 がエラーメッセージです。 何が原因でしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim rg As Range Dim r As Variant Dim c As Long Dim hanni1 As Range Dim atai As Range Set ws = Worksheets("あああ") Set rg = Worksheets("コード").Range("A1:B10") r = ws.Cells(Rows.Count, 1).End(xlUp).Row Set hanni1 = ws.Range(Cells(2, 2), Cells(r, 3)) Set atai = ws.Range(Cells(2, 3), Cells(r, 3)) atai = Application.VLookup(hanni1, rg, 2, False) End Sub
- ベストアンサー
- その他(プログラミング・開発)
- EXCEL VBA 指定した数字ごとに表示
・1から3までの数字をいれた場合に、9:00から11:00と表示する場合として以下のソースを書きます。(以前にこちらで教えていただきました) ・a = array()の部分について、直接書くのではなく、セルを参照することはできますでしょうか? a = array("cell(1,1)", "cell(1,2)", "cell(1,3)")みたいなイメージです。 よろしくお願い致します。 option base 1 private sub Worksheet_Change(byval Target as excel.range) dim h as range dim a as variant a = array("9:0", "10:0", "11:0") ’1から3 on error resume next for each h in application.intersect(target, range("D:D")) if cells(h.row, "F") <> "○" then if 1=< h.value and h.value <= 3 then ’1から3 if time >= timevalue(a(h.value)) then cells(h.row, "F") = a(h.value) end if end if end if next end sub
- ベストアンサー
- Excel(エクセル)
- EXCEL VBAの配列でわかりません。
こんなコードがあるのですが、最後の他のシート(作業中シート)に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ~??わからな~い??おしえてくださーい!! Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub
- ベストアンサー
- オフィス系ソフト
- VBA 同じ場所に保存する
部署ごとに分割し、ブックで保存するコードです。 保存場所がデスクトップになっています。 これを同じ場所に保存する方法をお知らせください。 よろしくお願いします。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 2 To w.Range("A65536").End(xlUp).Row s = w.Cells(r, "A") w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = WSH.specialfolders("Desktop") & "\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") Resume Application.ScreenUpdating = True End Sub
- ベストアンサー
- Visual Basic
- VBAで教えてください。
以前ここで教えていただいたVBAで http://jisaku.155cm.com/src/1371930716_9b9006528605642980beed48a8998013b0731e4b.jpg のようにA列のテスト4をクリックしたときにC列のテスト4が一発で解るようにしたいです。 もちろん、テスト11をクリックしたときは、テスト4塗りつぶしは解除され、 テスト11が塗りつぶされるようにしたいです。 写真は塗りつぶししていますが、解るようにしたいだけなので、塗りつぶしにはこだわっていません。 あと、E、F、G列は解りやすく並べているだけで、実際はA、B、C列だけです。 それと、C列は関数を使って表示してあります。 という質問で Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'この行から Dim i As Long Range("C:C").Interior.ColorIndex = xlNone If Application.Intersect(Target, Range("A:A")) Is Nothing Or Target.Count <> 1 Then Exit Sub On Error Resume Next Application.ScreenUpdating = False ActiveSheet.Cells.interio.ColorIndex = xlNone For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, "C") = Target Then Cells(i, "C").Interior.ColorIndex = 3 End If Next i Application.ScreenUpdating = True End Sub 'この行まで をシートのコードに張り付ければいいですよ。と教えてくれたものがあるのですが、 A列でクリックした文字をC列からすべて見つけて反転してくれないようです。何個か反転してくれない ものが出てきてしまいました。 C列が何百行とかなってしまうと、すべての同じ文字を検索してくれないのでしょうか? ちなみに列がここに掲載しているものと違うので Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'この行から Dim i As Long Range("R:R").Interior.ColorIndex = xlNone If Application.Intersect(Target, Range("B:B")) Is Nothing Or Target.Count <> 1 Then Exit Sub On Error Resume Next Application.ScreenUpdating = False ActiveSheet.Cells.interio.ColorIndex = xlNone For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, "R") = Target Then Cells(i, "R").Interior.ColorIndex = 3 End If Next i Application.ScreenUpdating = True End Sub 'この行まで のCをRにAをBに変更して使ってます。 これがいけないのかな? よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでワークシートのコメントを全部削除
以下のコードを走らせると実行時エラー91[オブジェクト変数またはwithブロック変数が設定されていません]となってしまいます。 On Error Resume Nextで回避出来るのですが、理由がわかりません。On Error Resume Nextで回避しなくともいいようにするにはどう直せばいいのでしょうか? Sub Del_Comment() Dim MyR As Range, C As Range Set MyR = Cells.SpecialCells(xlCellTypeComments) For Each C In MyR C.Comment.Delete Next End Sub
- ベストアンサー
- オフィス系ソフト
- 【vba】複数のセルをfor文で選択したい
vbaを独学で学んでおります。 質問内容は、 for文で条件に合ったセルを複数選択するにはどうすればいいのかというものです。 下のプログラムを作ってみたんですが、ループする回数がある一定の数を超えるとエラーが起こります。rangeオブジェクトにつかえる文字列の長さは、255文字までだとかなんとかだそうです。 Public Sub test() Dim str As String Dim i As Integer str = Cells(1, 1).Address For i = 2 To 50 str = str & "," & Cells(i, i).Address Next Range(str).Select End Sub さらに、次のプログラム使っても、256個ぐらいしかセルが選択できません。(これも何かの上限?) Public Sub test2() On Error GoTo エラー Dim r As Range Dim i As Integer Set r = Cells(1, 1) For i = 2 To 300 Set r = Union(r, Cells(i, i)) Next r.Select エラー: r.Select MsgBox ("256個しか選べませんでした") End Sub もっと、無制限に、たくさんのセルを選択できるようにしたいのですが、何か手はないでしょうか? ご教授お願いします。
- ベストアンサー
- Visual Basic
- 文字列を分割して、分割した文字の一番右側を表示するにはどうしたら良いのでしょうか?
Sub test2() Dim moji() As String Dim a As Range Dim 行 As Long For 行 = 2 To Cells(Rows.Count, 1).End(xlUp).Row Set a = Cells(行, 1) moji() = Split(a, "-") On Error GoTo moji Cells(行, 2) = moji(3) Next 行 moji: Cells(行, 2) = moji(2) End Sub で A列 B列 1-2-3-4 4 10-11-11-12 12 1-2-3-10 10 1-2-10-3 3 1-2-3 3 1-2 1-13 11-14 11-3 の結果になりますが1-2,11-14,11-3の部分が表示できません。 どなたかよいほうほうをお願いします。
- 締切済み
- オフィス系ソフト
お礼
大変助かりました。 ありがとうございますm(_ _)m また何かありましたら宜しくお願い致します。