• 締切済み

作成方法についての質問です。

下記のマクロで実行すると添付画像[現状]のようになってしまいます。 私としては[こうなってほしい]の形にしたいのですが、どこに何を組み込めばよいかわかりません。 誰か教えてください。 Dim Matches As Object Dim Match As Object Dim i As Long, j As Long Dim a As Variant With CreateObject("VBScript.RegExp") Set rng = Range("A1", Cells(Rows.Count, 1).End(xlUp)) Application.ScreenUpdating = False For i = 1 To rng.Rows.Count If InStr(1, rng.Cells(i, 1).Value, "(", 1) > 0 Then .Pattern = "\(([A-z\d,]+)" Else .Pattern = "([A-z\d,]+)" End If .Global = True Set Matches = .Execute(StrConv(rng.Cells(i, 1).Value, vbNarrow)) If Matches.Count > 0 Then a = Matches(0).SubMatches(0) a = Split(a, ",") Cells(i, 2).Resize(, UBound(a) + 1).Value = a End If j = 0 Next End With Application.ScreenUpdating = True Set rng = Nothing End Sub

みんなの回答

回答No.2

補足が分かりにくいです。。 私なりに整理してみましたがこんな感じでしょうか？

画像を拡大する
bankin0312
質問者

お礼

ありがとうございました。

bankin0312
質問者

補足

その通りです。 補足がわかりづらくてすいません。 どうすればいいのでしょうか。

全文を見る
すると、全ての回答が全文表示されます。
回答No.1

よくわかりません。 補足してください。 また添付画像はどれでしょうか。

bankin0312
質問者

補足

補足します。 下記の[現状]のように必要ない箇所まで表示されてしまいます。 わたしとしては[こうしたいです]のように括弧内のみを表示させたいです。 【現状】 R6001,R6003,R6004,R6009,R6011, R6001 R6003 R6004 R6009 R6011 R6027,R6029,R6030,R6032,R6033, R6027 R6029 R6030 R6032 R6033 R6044,R7001,R7025(R13,R15,R802, R13 R15 R802 R827,R1002,R1106,R1107,R1108, 　　　　　　R827 R1002 R1106 R1107 R1108 R1109,R1110,R1111,R1123,R4001,　　　　　 R1109 R1110 R1111 R1123 R4001 R5109,R5110,R5111,R5112,R5113, 　　　　　　R5109 R5110 R5111 R5112 R5113 R6007,R6016,R6031,R7003,R7014,　　　　 R6007 R6016 R6031 R7003 R7014 は実行) R5105,R5106,R5107,R5108 　　　　　　　　　　　　R5105 R5106 R5107 R5108 R5015,R5016 　　　　　　　　　　　　　　　　　　R5015 R5016 R503,R504,R505,R601,R602,　 　　　　　　R503 R504 R505 R601 R602 R6035,R6036 　　　　　　　　　　　　　　　　　　R6035 R6036 【こうしたいです】 R6001,R6003,R6004,R6009,R6011,R6026, R6027,R6029,R6030,R6032,R6033,R6034, R6044,R7001,R7008,R7025(R13,R15,R802, R13 R15 R802 R811,R827,R1002,R1106,R1107, 　　 R811 R827 R1002 R1106 R1107 R1109,R1110,R1111,R1123,R4001, R1109 R1110 R1111 R1123 R4001 R5109,R5110,R5111,R5112,R5113, R5109 R5110 R5111 R5112 R5113 R6007,R6016,R6031,R7003,R7014, R6007 R6016 R6031 R7003 R7014 は実行) R5105,R5106,R5107,R5108 R5015,R5016 R503,R504,R505,R601,R602,R603 R6035,R6036 以上です。

全文を見る
すると、全ての回答が全文表示されます。
  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • VBA　エクセル　文字列

    A列に、【鈴木　太郎】、【佐藤　一郎】・・・・と続いていて、B列には鈴木、佐藤・・・と表示させたい場合は以下のソースに、 =LEFT(A1,FIND(" ",SUBSTITUTE(A1,"　"," "))-1) と同じソースを書けばいいのはわかるのですが、勉強不足でわかりません。教えていただけませんでしょうか。下記のソースも教えていただきました。すごく助かります。 Sub PickupWords() Dim Matches As Object Dim Match As Object Dim buf As String Dim c As Variant With CreateObject("VBScript.RegExp") .Pattern = "【(.+)】" .Global = False Application.ScreenUpdating = False For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp)) If .Test(c.Value) Then buf = c.Value Set Matches = .Execute(buf) c.Offset(, 1).Value = Matches.Item(0).SubMatches(0) '括弧の中を取り出す End If Next c Application.ScreenUpdating = True End With End Sub

  • エクセル　最終行からの連続コピー

    エクセルで最終行から上に連続する１０行（最終行含む）をコピーしたいです。 途中、空白行が含まれている場合でも、最終行を特定し、コピーできるようにするには、下記のコードにどう手を加えたらよいでしょうか？ どなたかアドバイスをお願いします。 Sub Test() 　　Dim i As Long 　　Dim j As Integer 　　Dim rng As Range 　　With ActiveSheet 　　　　'フィルタ 　　　　.Range("A1").CurrentRegion.AutoFilter Field:=1 　　　　 　　　　'行選択 　　　　With .AutoFilter.Range 　　　　　　For i = .Cells(.Cells.Count).Row To 2 Step -1 　　　　　　　　If .Rows(i).Hidden = False Then 　　　　　　　　　　If rng Is Nothing Then 　　　　　　　　　　　　Set rng = .Rows(i) 　　　　　　　　　　Else 　　　　　　　　　　　　Set rng = Union(rng, .Rows(i)) 　　　　　　　　　　End If 　　　　　　　　　　j = j + 1 　　　　　　　　End If 　　　　　　　　If j >= 10 Then Exit For 　　　　　　Next i 　　　　　　'コピー 　　　　　　If Not rng Is Nothing Then 　　　　　　　　rng.Copy Worksheets("Sheet2").Range("A1") 　　　　　　　　Beep 　　　　　　Else 　　　　　　　　MsgBox "該当行は存在しません。", 48 　　　　　　End If 　　　　End With 　　End With 　　Set rng = Nothing なお、コードはこちらを参考にさせていただきました。 http://okwave.jp/qa3552420.html?ans_count_asc=1

  • Excel VBA　配列による複数セルへの入力

    VBA初心者です．よろしくお願いいたします． 用語の読みを自動で振るシートを作成しているのですが，Do Loop部分が一行ずつの入力となっていて，時間がかかっています． これを配列等の方法を用いて高速化したいと思って，試行錯誤したのですが，うまくいきません． 何卒お教えくださいますようお願いいたします． 用語の読みを生成する手順ですが， １．シート1に用語をペーストする ２．ペーストされた用語をシート２にある用語のDB（用語と読みが入力されています．重複レコードなし）にコピー ３．コピーされたシート２をピボットにして個数が２以上あった場合，その用語と読みを返します． ４．Do Loopで最初にヒットした用語に戻るまでループ となっています． ３までの手順に修正の必要はないのですが，４の手順でかなり時間をロスしております． ここを配列等の方法で一度に書き込むことができればと思っています． Sub test() i = 8 L_Row04 = 180188 Dim S1 As Worksheet '読みを振る用語をペーストするシート Dim S2 As Worksheet '読み用の用語のDB Dim S3 As Worksheet 'ピボット Dim L_Row01 As Long 'S1にペーストされた用語の最下行 Dim L_Row02 As Long 'S1の用語をs2にペーストしたときの最下行 Dim L_Row03 As Long 'ピボットの用語の最下行 Dim Rng01 As Range 'S1にペーストされた用語の範囲 Dim Rng02 As Range 'S2にペーストされた用語の範囲 Dim Rng03 As Range 'ピボットの範囲 Dim Str01 As Variant 'ピボットで2以上あったときの用語 Dim Str02 As Variant 'ピボットで2以上あったときの読み Dim firstcell As Range Dim Foundcell01 As Range Set S1 = Worksheets(1) Set S2 = Worksheets(2) Set S3 = Worksheets(3) S1.Activate L_Row01 = S1.Cells(Rows.Count, 2).End(xlUp).Row L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row Set Rng01 = S1.Range(Cells(i, 2), Cells(L_Row01, 2)) Rng01.Copy Destination:=S2.Cells(L_Row02 + 1, 2 + 1) S3.PivotTables("ピボットテーブル2").RefreshTable S2.Activate L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row Set Rng02 = S2.Range(Cells(L_Row04, 3), Cells(L_Row02, 3)) Rng02.Delete S3.Activate L_Row03 = S3.Cells(Rows.Count, 2).End(xlUp).Row Set Rng03 = S3.Range(Cells(4, 2), Cells(L_Row03, 2)) For Each a In Rng03 If a >= 2 And a.Offset(0, -1).Value <> "(空白)" And a.Offset(1, -1).Value <> "(空白)" Then Str01 = a.Offset(0, -1) Str02 = a.Offset(1, -1) S1.Activate Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole) Do Selection.Offset(0, 1).Value = Str02 Selection.Offset(0, 2).Value = "●" Loop Until ActiveCell.Address = firstcell.Address End If End If Next End Sub

  • マクロについて質問します。

    このようなマクロがあるのですが、内容を変更したらうまく動きません。 Sub 請求明細自動印刷() Application.ScreenUpdating = False Dim I As Integer Dim リンクシート As String For I = 3 To Cells(Rows.Count, "A").End(xlUp).Row If Cells(I, "A") <> 0 Then リンクシート = Cells(I, "E").Hyperlinks(1).SubAddress リンクシート = Left(リンクシート, InStr(リンクシート, "!") - 1) Sheets(リンクシート).PrintOut From:=2, To:=2 End If Next I End Sub ↑の内容の　ハイパーリンクセルを"E"から　Dに変更したので、 ↓のように　リンク先をDに変更したのですが、同じ書類が出ています （１０枚　多分　If Cells(I, "A") <> 0 Thenに該当するのが１０組なので・・・） Sub 請求明細自動印刷() Application.ScreenUpdating = False Dim I As Integer Dim リンクシート As String For I = 3 To Cells(Rows.Count, "A").End(xlUp).Row If Cells(I, "A") <> 0 Then リンクシート = Cells(I, "D").Hyperlinks(1).SubAddress リンクシート = Left(リンクシート, InStr(リンクシート, "!") - 1) Sheets(リンクシート).PrintOut From:=2, To:=2 End If Next I End Sub よくわからないのですが、どのよな形に変更するのか教えたください。 For I = 3 To Cells(Rows.Count, "A").End(xlUp).Row これは宣言文なのですか・・・・？ すみません　　急いでるので　調べるより早いと思いまして お願いします。

  • Excelでwatabeさんに複数のセルを参照

    Excel2007でwatabe007さんに以前に作って頂いたこのようなソースがあります。 Sub Test4() Dim LastO As Long, LastG As Long Dim i As Long, str As String Range("D3", Cells(Rows.Count, "F").End(xlUp)).ClearContents LastO = Cells(Rows.Count, "O").End(xlUp).Row Range("A3:C3").Value = Cells(LastO, "O").Resize(, 3).Value str = Range("A3").Value & Range("B3").Value & Range("C3").Value For i = 3 To LastO 　　If str = Cells(i, "O").Value & Cells(i, "P").Value & Cells(i, "Q").Value Then 　　　　LastG = Cells(Rows.Count, "D").End(xlUp).Row + 1 　　　　If LastG < 3 Then LastG = 3 　　　　Cells(LastG, "D").Resize(, 3).Value = Cells(i + 1, "O").Resize(, 3).Value 　　End If Next End Sub これにいつも格子をつけて文字がセンターになるようにしたいですがどうすればよろしいですか？解答よろしくお願いいたします。

  • マクロのソートについて

    A列:E列のセルデータがあって、空欄を省いて、コピペでるようにしたのでが、新たに、D列を最初にソート、後からB列・C列を連動させてソートしたいのですが、うまく処理できません。ご教授願えませんか。Sheets("ZZZZZZZ")のデータは１行おきのようなデータです。コピペまではできていますが、その後のソートについてお願いします。 Sub Macro1() Application.ScreenUpdating = False Dim Rng As Range Dim LastRow As Long '●ここをだけ"B2:B100"指定する For Each Rng In Sheets("ZZZZZZZ").Range("B2:B100") If Rng.Value <> "" Then LastRow = Sheets("QQQQQQQQ").Cells(Rows.Count, "B").End(xlUp).Row Sheets("QQQQQQQQ").Cells(LastRow + 1, "B").Resize(1, 3).Value = Rng.Resize(1, 3).Value End If Next Rng Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

  • エクセル　最終行からの連続コピー

    * すぐに回答を！ エクセルC20からI51までデータを１日１行ずつ入力します。 データが入力されている最終行から上に連続する１０行（最終行含む）をコピーしたいのですが、最終行から10行上をどのように認識させたらいいのか、わかりません。Offsetなど試してみましたがダメでした。 よろしくお願いします。 Sub dataコピー() Dim i As Long Dim j As Integer Dim rng As Range '最後尾から10行前までを選択 With Worksheets("月").Range(Cells(20, 3), Cells(51, 10)) For i = Cells(Rows.Count, 1).End(xlUp).Row To -10? If rng Is Nothing Then Set rng = .Rows(i) End If j = j + 1 If j >= 10 Then Exit For Next i 'コピー If Not rng Is Nothing Then rng.Copy Range("M1") Beep Else MsgBox "該当行は存在しません。", 48 End If End With Set rng = Nothing End Sub コードはこちらを参考にしました ​http://questionbox.jp.msn.com/qa5440189.html

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

    現在のブック内に出力されるとメモリの都合上時間がかかりすぎますそこで新規ブック１個に出力する構文を教えていただきたいのですが、宜しくお願いします。 Sub １１１１() 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

  • リストボックスの内容を検索したいが...

    エクセル2019を使っています。 添付画像のようにユーザーフォームにテキストボックスとリストボックスを作り、テキストボックスに入力した文字でリストボックスの内容を検索しようとコードを作成しました。 Private Sub TextBox1_Change() Dim LastRow As Integer Dim rng As Range, r As Range With Worksheets("Sheet1") If .AutoFilterMode <> True Then .Range("A1").AutoFilter End If LastRow = .Cells(Rows.Count, 1).End(xlUp).Row .Range("A1").AutoFilter 1, "*" & TextBox1.Value & "*" If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then Set rng = .Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible) Else Me.ListBox1.Clear Exit Sub End If End With Me.ListBox1.Clear With Me.ListBox1 For Each r In rng .AddItem r.Value .List(.ListCount - 1, 1) = r.Offset(0, 1).Value Next r End With End Sub Private Sub UserForm_Initialize() Dim LastRow As Integer Dim rng As Range, r As Range With Worksheets("Sheet1") If .AutoFilterMode <> True Then .Range("A1").AutoFilter End If LastRow = .Cells(Rows.Count, 1).End(xlUp).Row Set rng = .Range("A2:A" & LastRow) End With With Me.ListBox1 .ColumnCount = 1 For Each r In rng .AddItem r.Value .List(.ListCount - 1, 1) = r.Offset(0, 1).Value Next r End With ListBox1.ListIndex = 0 End Sub とりあえず検索はできるのですが、使用されていない文字や記号を入力したあとにバックスペースキーで入力した文字や記号を削除するとリストボックスの内容が意図した内容で表示されません。 どこを修正したらいいでしょうか。

  • ExcelにおけるVBAで、データの振り分けをしたい

    Sub a() Dim i As Long Dim s As Long Dim b As Worksheet Dim c As Worksheet Dim maxi As Long Dim maxs As Long Application.ScreenUpdating = False With ThisWorkbook Set b = .Worksheets("bbb") Set c = .Worksheets("ccc") End With maxi = b.Range("A1").CurrentRegion.Rows.Count maxs = c.Range("A1").CurrentRegion.Rows.Count For i = maxi To 2 Step -1 For s = maxs To 2 Step -1 If c.Cells(s, 1) = b.Cells(i, 1) And c.Cells(s, 2) = b.Cells(i, 2) Then c.Cells(s, 14) = b.Cells(i, 3) End If Next s Next i Application.ScreenUpdating = True End Sub ワークシートcとワークシートbの1列目と2列目が一致したときにだけ、cの14列目にbの3列目のデータを代入したく思い、以上のようなコードを書きましたが、重くて終わる様子がありません。 ・そもそもあっているのか、あっていないならどこを修正すればよいか ・早く終わるようにするにはどうしたらいいか アドバイスをよろしくお願いします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する