- 締切済み
作成方法についての質問です。
mariko_k_heartの回答
- mariko_k_heart
- ベストアンサー率0% (0/0)
補足が分かりにくいです。。 私なりに整理してみましたがこんな感じでしょうか？
関連する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
- ベストアンサー
- その他MS Office製品
- エクセル 最終行からの連続コピー
エクセルで最終行から上に連続する１０行（最終行含む）をコピーしたいです。 途中、空白行が含まれている場合でも、最終行を特定し、コピーできるようにするには、下記のコードにどう手を加えたらよいでしょうか？ どなたかアドバイスをお願いします。 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
- 締切済み
- その他MS Office製品
- 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
- ベストアンサー
- Visual Basic
- マクロについて質問します。
このようなマクロがあるのですが、内容を変更したらうまく動きません。 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 これにいつも格子をつけて文字がセンターになるようにしたいですがどうすればよろしいですか？解答よろしくお願いいたします。
- ベストアンサー
- Excel（エクセル）
- マクロのソートについて
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
- ベストアンサー
- Visual Basic
- エクセル 最終行からの連続コピー
* すぐに回答を！ エクセル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
- ベストアンサー
- Visual Basic
- リストボックスの内容を検索したいが...
エクセル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（エクセル）
- 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列目のデータを代入したく思い、以上のようなコードを書きましたが、重くて終わる様子がありません。 ・そもそもあっているのか、あっていないならどこを修正すればよいか ・早く終わるようにするにはどうしたらいいか アドバイスをよろしくお願いします。
- 締切済み
- Visual Basic
お礼
ありがとうございました。
補足
その通りです。 補足がわかりづらくてすいません。 どうすればいいのでしょうか。