- ベストアンサー
VBAのプロシージャが大きすぎる！エラーメッセージが出る原因と対処法
Randomizeの回答
- Randomize
- ベストアンサー率70% (38/54)
#1です。 提示されたコードを実行させたところ、こちらでもエラーは確認しましたが、原因は非常に簡単です。 >Worksheets(2).Cells(nR + WriteRowOffset, nC + WriteColumnOffset).Value = Worksheets(1).Cells(NowReadRow + WriteRowOffset, 12 + WriteColumnOffset).Value というところでエラーが発生していますが、一番初めにNowReadRowに値を入れ忘れており、その結果NowReadRow + WriteRowOffsetは0となり、0行目というExcelでは存在しないセルを参照しようとしているためです。仮にNowReadRowに初期値1を与えたところ、問題なく動作します。 前回補足で申しました値を配列に入れると高速になるという件で、 >行列については、 >>その代わり値しかコピーできない弱点もありますけどね。 >値だけでなく、文字列も入っている列があるので、難しいかと思います。 と、数字はコピーできても文字はコピーできないという風に勘違いされておられますので更に補足します。 この手法でコピーできるのはセルのValueプロパティーの中身のみであるという意味で「値のみ」という表現をしました。数字でも文字列でも取扱可能です。ただし、Valueプロパティー以外の値、すなわちセルや文字の色付け・文字揃え・罫線・フォント・結合状態・関数の式自体(結果はコピー可能)・グラフや図形はこの手法ではコピーできません。ですので、この方法を使用するときは色付けや罫線等を設定する時に条件付き書式などを多用することになります。 以上、補足回答です。
関連するQ&A
- VBAにてリストボックスに表示された文字をエクセルのセルにコピペするには
先日、ここで教えてもらった以下の内容で、幾つかのテキストボックスに表示された内容のうち、電話番号をエクセルのセルに転記する方法が、上手くいきません。”検索"名のシート上で実行します。 過去のログを参考にしましたが、解決できませんでした。 またお世話になりますが、だれか教えてください。 Private Sub CommandButton1_Click() Dim Namae As String Dim MeNamae As UserForm Dim ken As String Namae = TextBox1.Text Set MeNamae = UserForm1 Call 検索(Namae, MeNamae) End Sub Public Sub 検索(ByVal Namae As String, ByRef MeNamae As UserForm) Dim Nagasa As Integer Dim i As Long Dim MaxRows As Long Dim kensaku As Worksheet Dim KensakuChar As String Dim ListNamae As String Dim ListChar As String Dim KBanme As Integer Dim LBanme As Integer Set kensaku = Worksheets("顧客データ") MaxRows = kensaku.UsedRange.Rows.Count Nagasa = Len(Namae) MeNamae.ListBox1.Clear For i = 3 To MaxRows ListNamae = kensaku.Cells(i, 3) KBanme = 0 LBanme = 0 Do Do While Nagasa >= KBanme KBanme = KBanme + 1 KensakuChar = Mid(Namae, KBanme, 1) If KensakuChar <> " " Then Exit Do End If Loop Do While Nagasa >= LBanme LBanme = LBanme + 1 ListChar = Mid(ListNamae, LBanme, 1) If ListChar <> " " Then Exit Do End If Loop If KensakuChar = ListChar Then If Nagasa = KBanme Then With MeNamae .ListBox1.AddItem (ListNamae) .ListBox1.List(.ListBox1.ListCount - 1, 1) = i End With End If Else Exit Do End If Loop Until Nagasa <= KBanme Next End Sub Private Sub ListBox1_Click() Dim r As Long With ListBox1 If .ListIndex > -1 Then r = .List(.ListIndex, 1) '選択した名前の行 TextBox6.Value = Worksheets("顧客データ").Cells(r, 3) 'カタカナ名 TextBox2.Value = Worksheets("顧客データ").Cells(r, 5) '漢字名 TextBox3.Value = Worksheets("顧客データ").Cells(r, 7) '住所 TextBox4.Value = Worksheets("顧客データ").Cells(r, 1) '電話番号 TextBox5.Value = Worksheets("顧客データ").Cells(r, 2) '顧客番号 End If End With End Sub Private Sub CommandButton3_Click() 'クリックすると Worksheets("検索").Cells(, 2) ’このシートの(G2)に上記の電話番号が入力される End Sub
- ベストアンサー
- Visual Basic
- ＶＢＡでの説明がわかりません
以下のコードは、都道府県ごとに１枚のデータシートを作成する処理なんですが、コードが１行づつどんな作業を意味しているのかがわかりません。１行ごとにどのような処理をしているのかの説明をよろしくお願いします。長文で申し訳ありません。 Sub まとめ() Dim i As Integer 'カウンタ変数iの宣言 Dim n As Integer Dim MyS1 As Worksheet 'ワークシート型オブジェクトMyS1を宣言 Dim MyC As Worksheet Worksheets.Add before:=Worksheets("全国") ActiveSheet.Name = "data" Set MyS1= Worksheets("data") With Worksheets("全国") MyS1. Range(MyS1.Cells(1,1),MyS1.Cells(11,12))=.Range(Cells(1,1),.Cells(11,12)).Value End With i=12 For Each MyC In Worksheets If MyC.Name<> "data" Then n = 12 MyS1.Cells(i,1)=MyC.Name i=i+1 Do While MyC.Cells(n,2).Value<>"" MyS1.Range(MyS1.Cells(i,1),MyS1.Cells(i,12))=MyC.Range(MyC.Cells(n,1),Mc.Cells(n,12)).Value i=i+1 n=n+1 Loop End If Next Myc End Sub
- ベストアンサー
- オフィス系ソフト
- vba 四捨五入 について教えてください。
VBA初心者です。お世話になりますがよろしくお願いします。 vbaでRound関数を使って四捨五入したいと考えております。 以下のコードで実行するとエラー(プロシージャの呼び出し,または引数が不正です。）が出ます。 何がなんだかわからずに困っております。 どうかご教授よろしくお願いします。 Sub 計算() Worksheets("abc").Activate Dim LastRow As Long Dim i As Integer LastRow = Worksheets("abc").Range("K65536").End(xlUp).Row For i = 6 To LastRow If Cells(i, 11) = 0 Then Cells(i, 12) = "" Else Cells(i, 12) = Round(Cells(i, 9) / Cells(i, 11),-2) End If Next End Sub
- ベストアンサー
- Visual Basic
- 【Excel VBA】データ貼り付けの開始位置について
Excel2003を使用しています。 先日、こちらでアドバイスをいただきながら、下記のようなマクロを作りました。内容はあるセルの値と同じ名前のシートへデータをコピーするというものです。 Sheet1に貼り付け元のデータが表形式であり、必要なデータのみ該当のシートへコピーします。マクロ実行後は、別の新しいデータをSheet1へコピペして、またマクロを実行するのですが、その際、データの貼り付け開始位置を前回マクロを実行して貼り付けられたデータから2行空けたいのですが、可能でしょうか？ ________________________________________________________________________________________________________________________________ Sub test3() Dim n As Long Dim i As Long Dim j As Long Worksheets("Sheet1").Activate For n = 4 To Cells(Rows.Count, 2).End(xlUp).Row If Cells(n, 3).Value <> "" Then With Worksheets(CStr(Cells(n, 3).Value)) i = .Cells(Rows.Count, 3).End(xlUp).Row + 1 Cells(n, 2).Copy .Cells(i, 2) Cells(n, 7).Resize(, 2).Copy .Cells(i, 4) Cells(n, 11).Copy .Cells(i, 3) End With End If If Cells(n, 13).Value <> "" Then With Worksheets(CStr(Cells(n, 13).Value)) j = .Cells(Rows.Count, 3).End(xlUp).Row + 1 Cells(n, 12).Copy .Cells(j, 2) Cells(n, 17).Copy .Cells(j, 4) Cells(n, 18).Copy .Cells(j, 6) Cells(n, 11).Copy .Cells(j, 3) End With End If Next n End Sub
- ベストアンサー
- オフィス系ソフト
- VBA リストボックスについて
VBA初心者です。どうぞよろしくお願いします。 ユーザーフォームにタブつきのリストボックスを作りたいと思っています。 リストはsheet1の中にあります。 A B C D・・・ 1 NO 品名 売場 2 1 いちご 果物 3 2 みかん 果物 4 3 もも 果物 5 4 ハクサイ 野菜 6 5 キャベツ 野菜 7 6 きゅうり 野菜 8 7 9 果物のタブには、果物の品名が表示される。 1 いちご 2 みかん 3 もも 野菜のタブには、野菜の品名が表示される。 4 ハクサイ 5 キャベツ 6 きゅうり 青果のタブには、果物、野菜が表示される。 1 いちご 2 みかん 3 もも 4 ハクサイ 5 キャベツ 6 きゅうり 本を見ながら格闘しておりますが、きっと的違いで滅茶苦茶なことをしているのだと思います。 どうにも出来ず困っております。どなたか教えていただけないでしょうか。よろしくお願いします。 Private Sub UserForm_Initialize() Dim LastRow As Long Dim i As Integer Dim ListBoxNo As Integer Dim ListBox As Control Dim Listtabu(3) As Long 'タブの数 For i = 1 To 3 Listtabu(i) = 0 Next i Worksheets("sheet1").Activate With Worksheets("sheet1") LastRow = .Range("A65536").End(xlUp).Row For i = 2 To LastRow If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" Then ListBoxNo = 1 Set ListBox = 果物 果物.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "野菜" Then ListBoxNo = 2 Set ListBox = 野菜 野菜.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" & "野菜" Then ListBoxNo = 3 Set ListBox = 青果 青果.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If ListBox.AddItem ListBox.List(Listtabu(LstBxNo), 0) = Worksheets("sheet1").Cells(i, 1).Value ListBox.List(Listtabu(LstBxNo), 1) = Worksheets("sheet1").Cells(i, 2).Value Listtabu(LstBxNo) = Listtabu(LstBxNo) + 1 Next End With End Sub
- ベストアンサー
- Visual Basic
- VBAで教えてください。
データがないときはExitSubしたいのですが、何処に記述すれば良いでしょうか？ Sub 削除() Dim i As Long If MsgBox("データを削除します。よろしいですか？", vbYesNo) = vbYes Then Sheets("リスト").Select i = 5 Do Until i = 200 If Cells(i, 5).Value = Sheets("マスタ登録").Range("D5") Then Cells(i, 1).EntireRow.Delete End If i = i + 1 Loop Else Exit Sub End If End Sub
- ベストアンサー
- オフィス系ソフト
- ＶＢＡ 任意のシートからコピーを始める。
教えてください。 全てのシートをコピーして一つのシートにまとめるプログラムシートを作成しました。 1番目のシートからコピーを始める場合は For i = 2 To Worksheets.Count 2番目のシートからコピーを始める場合は For i = 3 To Worksheets.Count とすればよいのですがこれだといちいちモジュールコードを出して数字を変更しなければならず面倒です。 そこでユーザーフォームのコンボボックスに任意の数字を入れてクリックを押せば希望するシートからコピーを始めるプログラムを作成してみましたがうまくいきません。どなたか教えてくださいませんか。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long, lRow3 As Long, SNo As Integer '----何番目からコピーを始めるかを決定します With UserForm2 SNo = .ComboBox1.value End With For i = 1 + SNo To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが2行以上の場合にコピーします If lRow >= 2 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 If lRow2 < Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 Then lRow2 = Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i
- ベストアンサー
- Visual Basic
- VBA Range・Cellsプロパティについて
下記のコードについて質問致します。 Sub 特定のセルをコピー() Dim rw2 As Long Dim rw1 As Long Dim newdate As Date With Worksheets("steet1") rw2 = .cells(.Rows.Count, "c").End(xlUp).Row newdate = .Range("c" & rw2).value For rw1 = rw2 - 1 To 1 Step -1 If .Range("c" & rw1).value <> newdate Then Exit For Next rw1 .Range(.cells(rw1 + 1, 1), .cells(rw2, 1)).Copy '(1) Worksheets("steet2").Range("v6").PasteSpecial xlValue End With End Sub (1)部分のコードの意味が分かりません。 よろしくお願いします。
- ベストアンサー
- Visual Basic
- VBA リストボックス（複数条件）で検索⇒転記方法
VBA初心者です。 入門書を読み、コンボボックスを用いる（一つの条件検索）で請求書ツール作成までできたのですが、画像のようにユーザーフォームに複数選択リストを設けると現在のコードですと、エラーになってしまいます。 つきましては、リストボックスで条件を複数選択可能にして、該当データを転記するといったことを行いたいです。大変恐縮ですが、コードをご教示お願い致します。 ↓参考に、現状のコードを下記致します。 （ユーザーフォームのコード） Private Sub btnExit_Click() Unload Me End Sub Private Sub UserForm_Initialize() Dim ListRange As Range Dim temp As Range Dim vYear As Long Dim i As Long With Worksheets("取引先一覧").Range("A1").CurrentRegion Set ListRange = .Resize(.Rows.Count - 1).Offset(1) End With For Each temp In ListRange cmbcompany.AddItem temp.Value Next vYear = Year(Date) cmbYear.AddItem vYear - 1 cmbYear.AddItem vYear cmbYear.AddItem vYear + 1 cmbYear.Value = vYear For i = 1 To 12 cmbMonth.AddItem i Next End Sub Private Sub btnMakeBill_Click() MakeBill cmbcompany.Text, cmbYear.Text, cmbMonth.Text End Sub （標準モジュールのコード） Option Explicit Sub Main() frmMakeBill.Show End Sub Sub MakeBill(ByVal vCompany As String, ByVal vYear As Long, ByVal vMonth As Long) Dim TargetSheet As Worksheet Dim vDate As Date Dim DataRange As Range Dim TargetRange As Range Dim BillBook As Workbook Dim i As Long, vRow As Long Dim vInfo(1 To 2) As String On Error Resume Next Worksheets("請求書Template").Copy After:=Worksheets(Worksheets.Count) If Err.Number <> 0 Then MsgBox "「請求書Template」ワークシートが見つかりません。確認下ください" Exit Sub End If On Error GoTo 0 On Error GoTo ErrHdl Set TargetSheet = Worksheets(Worksheets.Count) Set TargetRange = TargetSheet.Range("A18") i = 1 vRow = 1 With Worksheets("受注データ").Range("A9") Do Until .Cells(i, 1).Value = "" vDate = .Cells(i, 1).Value If .Cells(i, 2).Value = vCompany _ And Year(vDate) = vYear And Month(vDate) = vMonth Then TargetRange.Cells(vRow, 1).Value = .Cells(i, 1).Value '「日付」列 TargetRange.Cells(vRow, 2).Value = .Cells(i, 3).Value '「商品コード」列 TargetRange.Cells(vRow, 3).Value = .Cells(i, 4).Value '「商品名」列 TargetRange.Cells(vRow, 4).Value = .Cells(i, 5).Value '「数量」列 TargetRange.Cells(vRow, 5).Value = .Cells(i, 6).Value '「単価」列 TargetRange.Cells(vRow, 6).Value = .Cells(i, 7).Value '「金額」列 vRow = vRow + 1 End If i = i + 1 Loop TargetSheet.Range("F28").Formula = "=SUM(F18:F27)" '「小計」 TargetSheet.Range("F29").Formula = "=F28 * 0.08" '「消費税額」 TargetSheet.Range("F30").Formula = "=F28 + F29" '「合計金額」 TargetSheet.Range("B6").Formula = "F30" '請求額 vInfo(1) = Date vInfo(2) = vCompany TargetSheet.Range("F2").Value = vInfo(1) '「請求日」 TargetSheet.Range("A6").Value = vInfo(2) '「請求先」 End With Set BillBook = Workbooks.Add TargetSheet.Cells.Copy BillBook.Worksheets(1).Range("A1") Application.DisplayAlerts = False TargetSheet.Delete Application.DisplayAlerts = True Exit Sub ErrHdl: MsgBox "エラーが発生しました。処理を終了します" End Sub
- 締切済み
- Visual Basic
- ２つのVBAを組み合わせる方法
お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？
- ベストアンサー
- Excel（エクセル）
お礼
Randomize様、ありがとうございました。仰っているように、NowReadRowに値を入れたら、問題なく動きました。行列についても、よく分かりました。本当にありがとうございました。