- ベストアンサー
実行中のログをフォームのテキストボックスに表示したい
excel2000のVBAでフォームのテキストボックスに実行ログを表示させていのですが、以下のものだと全ての処理が終了したときに表示されてしまいます。 私が望むのは、イミディエイト風に現在の実行状況（一行づつ）を表示したいのですが、アドバイスをお願いします。 Private Sub bA_Click() nCnt = ActiveWorkbook.Worksheets.Count For I = 1 To nCnt With ActiveWorkbook If (.Worksheets(I).Name = "A") Then Call Update_All(.Worksheets(I).Name) End If End With Next I End Sub Function Update_All(sSheetName As String) Call DB_Connect(Connect) Set Myws = DBEngine.CreateWorkspace("ODBC", "User", "Password", dbUseODBC) Set Myco = Myws.OpenConnection("", dbDriverNoPrompt, False, Connect$) Myco.QueryTimeout = 3600 With Worksheets(sSheetName) Do Until (.Cells(I, 1) = "") For J = 3 To 24 If .Cells(I, J) > 0 Then PRICE = .Cells(I, J) Spproc$ = "UPDATE AAA SET A.MPRIC=CONVERT(INT,A.WEGT*" & PRICE & "+0.5) " & "FROM AAA A,BBB B " tLOG.SelText = Format(Now(), "hh:mm:ss") & Chr(9) & "更新開始・・・" & vbCrLf Set Myset = Myco.OpenRecordset(Spproc$, dbOpenDynamic, 0, dbOptimistic) Myset.Close tLOG.SelText = Format(Now(), "hh:mm:ss") & Chr(9) & "更新終了・・・" & vbCrLf End If Next I = I + 1 Loop End With Myco.Close Myws.Close End Function
- adama2005
- お礼率100% (2/2)
- Visual Basic
- 回答数2
- ありがとう数4
- みんなの回答 （2）
- 専門家の回答
質問者が選んだベストアンサー
テキストボックスに文字を設定した後にDoEventsを入れればいけると思います。 が、その他のExcelでの操作もできるようになってしまうので、注意が必要です。 詳しくはDoEventsをヘルプで調べてみてください。
その他の回答 (1)
関連するQ&A
- 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で空欄にデータに表示
エクセルVBAのIFを使って、シートaのA列に値があって、B列が空欄の場合のみ、空欄のセルにシートbの値を表示させたいです。 上手くできませんでしたので、教えてください。 Sub Do文2() Dim i As Integer i = 1 If Worksheets("a").Cells(i, 2) = "" Then Do While Worksheets("a").Cells(i, 1) <> "" Worksheets("a").Cells(i, 2) = Worksheets("b").Cells(1, 1) i = i + 1 Loop End If End Sub
- ベストアンサー
- Windows Vista
- 複数選択可能なリストボックス
Excel VBAの質問をさせてください。 シート(sheet1)のA列、セルA1から以下のデータがあるとします。 みかん りんご バナナ 苺 梨 バナナ バナナ みかん フォームのリストボックスで"みかん"と"バナナ"を選択した際、シート(sheet2)のセルA1にコピーしていきたいのですが機能しません。 単品、"みかん"だけを選択しても何もコピーされません。 どこがいけないでしょうか?? Private Sub UserForm_Initialize() With ListBox1 .AddItem "みかん" .AddItem "りんご" .AddItem "バナナ" .AddItem "苺" .AddItem "梨" .MultiSelect = fmMultiSelectMulti End With End Sub Private Sub CommandButton1_Click() Dim i As Long For i = 1 To 8 If Worksheets("Sheet1").Cells(i, "A").Value = Me.ListBox1.Value Then Worksheets("Sheet1").Cells(i, "A").Copy Worksheets("Sheet2").Cells(i, "A") End If End Sub
- ベストアンサー
- Visual Basic
- ExcelVBAでのユーザーフォームについて
ご回答ありがとうございました。 これといった資料がなく(探し方が悪いのかもしれませんが)、少ない経験値で複雑なというか面倒な処理のマクロ(VBA)を組まされることになり、困っているところです。当初の話だと「勉強しながらでよい」ということだったのですが、いろいろと仕事が次々と舞い込んできて、そんな余裕もなくせっぱ詰まり少ない知識で必死にやっています。 先にご回答いただいた内容で是非アドバイスをいただきたいと思い、新たに質問させていただきました。 ユーザーフォームでマルチページを作っています。そこでもコンボボックスを使うのですがそこの記述方法をアドバイス下さい。やっぱり記述場所がおかしいのか、クリックするとリストの内容がコンボボックスをクリックした分だけ繰り返してしまうことがあります。 ////////////////////////////////////////////////////// Private Sub UserForm_Initialize() Dim sh As Worksheet Set sh = Worksheets("対象年") Dim i As Integer Dim lastRow As Integer lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row With ComboBox1 For i = 2 To lastRow If ComboBox1 = "" Then .AddItem sh.Cells(i, 1).Value End If Next i End With End Sub ////////////////////////////////////////////////////// Private Sub ComboBox1_DropButtonClick() Dim sh As Worksheet Set sh = Worksheets("対象年") Dim i As Integer Dim lastRow As Integer lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row With ComboBox1 For i = 2 To lastRow If ComboBox1 = "" Then .AddItem sh.Cells(i, 1).Value End If Next i End With End Sub ////////////////////////////////////////////////////// とまぁ、結局コードは同じなのですが。 それと、結果をラベルに出させる場合には回答で記述いただいた ////////////////////////////////////////////////////// Private Sub ComboBox1_Change() Dim vTgYear As Variant vTgYear = ComboBox1.Value Label1.Caption = vTgYear - 1 & "～" & vTgYear + 1 & "年" End Sub ////////////////////////////////////////////////////// で、よいでしょうか？ よろしくお願いいたします。
- ベストアンサー
- Visual Basic
- ユーザーフォームのテキストボックスでVLOOK
ユーザーフォームのテキストボックスで、ご教示お願いいたします。 現在、以下のようなコードこちらで教えていただきセルに入力をしております。 上から順番に入力した際、テキストボックス5に値を入たら、 listのシートから該当するもの（項目は20個）をテキストボックス6に表示させたいと思っております。 ■現在のコード '// Private Sub CommandButton1_Click() Dim LastRow As Long 'ここはキャメル形式やパスカル形式にします/大文字は定数です。 Dim i As Long '/テキストボックスに値があるか調べる For i = 1 To 7 Next i '/セルに書き込み With Worksheets("Sheet1") LastRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 For i = 1 To 7 .Cells(LastRow, i).Value = Me.Controls("TextBox" & i).Value Next End With '/TextBox1-7をクリア If MsgBox("テキストボックスを空にしてよろしいですか？", vbQuestion + vbYesNo) = vbYes Then For i = 1 To 7 Me.Controls("TextBox" & i).Value = "" Next i End If 'TextBox1にフォーカスを移動 Me.TextBox1.SetFocus End Sub ■付け足したいコード Private Sub textbox5_change() Dim temp, x temp = Me.textBox5.Value If IsNumeric(temp) Then temp = Val(temp) x = Application.VLookUp(temp, Sheets("list").Range("a1:b20"), 2, False) If Not IsError(x) Then Me.TextBox6.Value = x Else MsgBox Me.TextBox5.Value & " はリストにありません" End If End Sub 【質問内容】 付け足したいコードは上記の通りですが、どのように付け足せばいいのかが分からず、 困っております。 度々で申し訳ありませんが、テキストボックス5の値を見て、 テキストボックス6に表示させるやり方をご教示お願いいたします。
- 締切済み
- オフィス系ソフト
- エクセル VBAのオートフィルター実行時エラー
エクセル VBAのオートフィルター実行時エラーについて教えて下さい VBAのオートフィルター実行時エラーで「’rangeクラスのAutoFilterメッソドが失敗しました’」 が表示されるのですが、エラーの内容がわかりません。教えて下さい。 Sub 複数条件でのデータ抽出() Const OrigSheetName = "データベース" Const PasteSheetName = "検索＆抽出" Const ItemRow = 2 Const FirstColumn = "A" Const LastColumn = "CH" Const UnnecessaryColumns = "W:CD" Const SearchColumn1 = "CF" Const SearchColumn2 = "I" Const PasteCell = "A2" Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _ LastRow As Long, Region As Variant, Period(1, 1) As Variant, _ temp As Variant, i As Long, c As Range Period(0, 0) = "1905/1/1" Period(1, 0) = "9999/12/31" Period(0, 1) = "以降" Period(1, 1) = "以前" If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then MsgBox "元データが入力されているシートとして設定されている" _ & vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set OrigSheet = Sheets(OrigSheetName) If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then MsgBox "データの転記先のシートとして設定されている" _ & vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set PasteSheet = Sheets(PasteSheetName) With OrigSheet LastRow = .Range(LastColumn & Rows.Count).End(xlUp).Row With .Range(LastColumn & Rows.Count).End(xlUp) If LastRow > .Row Then LastRow = .Row End With If LastRow <= ItemRow Then GoTo label9 label1: Region = Application.InputBox("参加または不参加を入力！", SearchColumn2 & _ "列に入力されている区分（Ａ組またはＢ組）の中で、抽出条件を入力して下さい", _ , Type:=6) If Region = vbNullString Or Region = False Then temp = MsgBox("区分が入力されていません。" & vbCrLf _ & "区分の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:区分の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "区分未入力") If temp = vbNo Then Exit Sub Else GoTo label1 End If End If For i = 0 To 1 label2: Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _ "列に入力されている日付" _ & "で抽出する期間を指定して下さい。", _ Period(i, 0), Type:=2) If Period(i, 0) = vbNullString Or Period(i, 0) = False Then temp = MsgBox("日付が入力されていません。" & vbCrLf _ & "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:日付の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "日付未入力") If temp = vbNo Then Exit Sub Else GoTo label2 End If End If If IsDate(Period(i, 0)) Then If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _ Then GoTo label3 End If temp = MsgBox("入力された値は日付として扱う事が出来ません。" _ & vbCrLf & "日付の入力をやり直して下さい。", _ vbOKOnly + vbExclamation, "入力値不適切") GoTo label2 label3: Period(i, 0) = DateValue(Period(i, 0)) Next i End With With Application .ScreenUpdating = False .Calculation = xlManual End With With OrigSheet .Columns(UnnecessaryColumns).Hidden = True With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow) .AutoFilter Field:=1, Criteria1:=Region .AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _ Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0) End With Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow) i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count End With If i > 1 Then With PasteSheet .Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear c.SpecialCells(xlCellTypeVisible).Copy With .Range(PasteCell) .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats End With End With End If With c.EntireColumn .AutoFilter .Hidden = False End With If i > 1 Then GoTo labelE label9: MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _ & "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i labelE: With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub １か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集（列の追加）しましたが、元となるセルは変更しています。 宜しくお願いします！
- 締切済み
- Visual Basic
- エクセル VBAのオートフィルター実行時エラー
VBAのオートフィルター実行時エラーで「’rangeクラスのAutoFilterメッソドが失敗しました’」 が表示されるのですが、エラーの内容がわかりません。教えて下さい。 Sub 複数条件でのデータ抽出() Const OrigSheetName = "データベース" Const PasteSheetName = "検索＆抽出" Const ItemRow = 2 Const FirstColumn = "A" Const LastColumn = "CH" Const UnnecessaryColumns = "W:CD" Const SearchColumn1 = "CF" Const SearchColumn2 = "I" Const PasteCell = "A2" Dim OrigSheet As Worksheet, PasteSheet As Worksheet, _ LastRow As Long, Region As Variant, Period(1, 1) As Variant, _ temp As Variant, i As Long, c As Range Period(0, 0) = "1905/1/1" Period(1, 0) = "9999/12/31" Period(0, 1) = "以降" Period(1, 1) = "以前" If IsError(Evaluate("ROW('" & OrigSheetName & "'!A1)")) Then MsgBox "元データが入力されているシートとして設定されている" _ & vbCrLf & vbCrLf & OrigSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set OrigSheet = Sheets(OrigSheetName) If IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)")) Then MsgBox "データの転記先のシートとして設定されている" _ & vbCrLf & vbCrLf & PasteSheetName & vbCrLf & vbCrLf & _ "というシート名のシートが見つかりません。" & vbCrLf _ & "マクロを終了します。", vbExclamation, "存在しないシート" Exit Sub End If Set PasteSheet = Sheets(PasteSheetName) With OrigSheet LastRow = .Range(LastColumn & Rows.Count).End(xlUp).Row With .Range(LastColumn & Rows.Count).End(xlUp) If LastRow > .Row Then LastRow = .Row End With If LastRow <= ItemRow Then GoTo label9 label1: Region = Application.InputBox("参加または不参加を入力！", SearchColumn2 & _ "列に入力されている区分（Ａ組またはＢ組）の中で、抽出条件を入力して下さい", _ , Type:=6) If Region = vbNullString Or Region = False Then temp = MsgBox("区分が入力されていません。" & vbCrLf _ & "区分の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:区分の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "区分未入力") If temp = vbNo Then Exit Sub Else GoTo label1 End If End If For i = 0 To 1 label2: Period(i, 0) = Application.InputBox("期間指定" & i + 1, SearchColumn1 & _ "列に入力されている日付" _ & "で抽出する期間を指定して下さい。", _ Period(i, 0), Type:=2) If Period(i, 0) = vbNullString Or Period(i, 0) = False Then temp = MsgBox("日付が入力されていません。" & vbCrLf _ & "日付の入力をやり直しますか?" & vbCrLf & vbCrLf _ & "[はい]:日付の入力をやり直します" & vbCrLf _ & "[いいえ]:処理を中止してマクロを終了します", _ vbYesNo + vbExclamation, "日付未入力") If temp = vbNo Then Exit Sub Else GoTo label2 End If End If If IsDate(Period(i, 0)) Then If Format(Period(i, 0), "yyyy/mm/dd") = DateValue(Period(i, 0)) & "" _ Then GoTo label3 End If temp = MsgBox("入力された値は日付として扱う事が出来ません。" _ & vbCrLf & "日付の入力をやり直して下さい。", _ vbOKOnly + vbExclamation, "入力値不適切") GoTo label2 label3: Period(i, 0) = DateValue(Period(i, 0)) Next i End With With Application .ScreenUpdating = False .Calculation = xlManual End With With OrigSheet .Columns(UnnecessaryColumns).Hidden = True With .Range(SearchColumn1 & ItemRow & ":" & SearchColumn2 & LastRow) .AutoFilter Field:=1, Criteria1:=Region .AutoFilter Field:=Columns(SearchColumn1 & ":" & SearchColumn2).Columns.Count, _ Criteria1:=">=" & Period(0, 0), Operator:=xlAnd, Criteria2:="<=" & Period(1, 0) End With Set c = .Range(FirstColumn & ItemRow & ":" & LastColumn & LastRow) i = c.Resize(, 1).SpecialCells(xlCellTypeVisible).Cells.Count End With If i > 1 Then With PasteSheet .Range(PasteCell & ":" & .Cells.SpecialCells(xlCellTypeLastCell).Address).Clear c.SpecialCells(xlCellTypeVisible).Copy With .Range(PasteCell) .PasteSpecial Paste:=xlPasteValuesAndNumberFormats .PasteSpecial Paste:=xlPasteFormats End With End With End If With c.EntireColumn .AutoFilter .Hidden = False End With If i > 1 Then GoTo labelE label9: MsgBox DateCell & "該当するデータが見つかりません。" & vbCrLf _ & "マクロの実行を中止します。", vbExclamation, "データ無し" & vbCrLf & i labelE: With Application .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub １か月ほど前までは問題なく実行出来ていました。元のデータベースの表を編集（列の追加）しましたが、元となるセルは変更しています。 宜しくお願いします！
- 締切済み
- Visual Basic
- VBA - セル解除
コピーA列結合セルを解除して、解除した行にすべてに「OK」と入れたいのですがうまくいきません。 アドバイスをお願い致します。 Dim i, Addr Worksheets("Sheet1").Range("A:A").Copy With Worksheets("Sheet2") .Range("A1").PasteSpecial . . If .Cells(i, 1).MergeCells Then Addr = .Cells(i, 1).MergeArea.Address .Cells(i, 1).UnMerge .Cells(i, 1)(Addr) = "OK" '←ここがダメです。 End If . .
- ベストアンサー
- Visual Basic
- VBA プロシージャが大きすぎます
皆様、こんにちは。 次のようなプロシージャを書きましたが、プロシージャが大きすぎますというエラーメッセージが出てしまいます。最初は2つのサブに分けてみましたが、正しく動かなくなりました。できれば、文書自体を短くしたいですが、方法がありましたら教えてください。どうぞよろしくお願いします。 Sub Test() Dim nR As Long Dim nC As Long Dim i As Long nR = 2 nC = 2 i = 68 i1 = 69 i2 = 70 ... i41 = 110 With Worksheets(1) Do If .Cells(i, 11).Value <> "" Then With Worksheets(2) Do If .Cells(nR, nC).Value = "" Then Exit Do End If nR = nR + 41 Loop .Cells(nR, nC).Value = "1.1" .Cells(nR, nC + 1).Value = "計" .Cells(nR, nC + 2) = Worksheets(1)Cells(i, 14) .Cells(nR, nC + 3) = Worksheets(1).Cells(i, 15) .Cells(nR, nC + 4) = Worksheets(1).Cells(i, 16) .Cells(nR, nC + 5) = Worksheets(1).Cells(i, 17) .Cells(nR, nC + 6) = Worksheets(1).Cells(i, 18) .Cells(nR, nC + 7) = Worksheets(1).Cells(i, 19) .Cells(nR, nC + 8) = Worksheets(1).Cells(i, 20) .Cells(nR, nC + 9) = Worksheets(1).Cells(i, 21) .Cells(nR, nC + 10) = Worksheets(1).Cells(i, 22) .Cells(nR, nC + 11) = Worksheets(1).Cells(i, 23) .Cells(nR, nC + 12) = Worksheets(1).Cells(i, 24) .Cells(nR, nC + 13) = Worksheets(1).Cells(i, 25) .Cells(nR, nC + 14) = Worksheets(1).Cells(i, 26) .Cells(nR, nC + 15) = Worksheets(1).Cells(i, 27) .Cells(nR, nC + 16) = Worksheets(1).Cells(i, 28) .Cells(nR, nC + 17) = Worksheets(1).Cells(i, 29) ... .Cells(nR + 41, nC + 1).Value = "燃料" .Cells(nR + 41, nC + 2) = Worksheets(1).Cells(i + 41, 14) .Cells(nR + 41, nC + 3) = Worksheets(1).Cells(i + 41, 15) .Cells(nR + 41, nC + 4) = Worksheets(1).Cells(i + 41, 16) .Cells(nR + 41, nC + 5) = Worksheets(1).Cells(i + 41, 17) .Cells(nR + 41, nC + 6) = Worksheets(1).Cells(i + 41, 18) .Cells(nR + 41, nC + 7) = Worksheets(1).Cells(i + 41, 19) .Cells(nR + 41, nC + 8) = Worksheets(1).Cells(i + 41, 20) .Cells(nR + 41, nC + 9) = Worksheets(1).Cells(i + 41, 21) .Cells(nR + 41, nC + 10) = Worksheets(1).Cells(i + 41, 22) .Cells(nR + 41, nC + 11) = Worksheets(1).Cells(i + 41, 23) .Cells(nR + 41, nC + 12) = Worksheets(1).Cells(i + 41, 24) .Cells(nR + 41, nC + 13) = Worksheets(1).Cells(i + 41, 25) .Cells(nR + 41, nC + 14) = Worksheets(1).Cells(i + 41, 26) .Cells(nR + 41, nC + 15) = Worksheets(1).Cells(i + 41, 27) .Cells(nR + 41, nC + 16) = Worksheets(1).Cells(i + 41, 28) .Cells(nR + 41, nC + 17) = Worksheets(1).Cells(i + 41, 29) End With Else Exit Do End If i = i + 51 i1 = i1 + 51 ... i41 = i41 + 51 Loop End With End Sub できれば、まとめて .Range(Cells(nR, nC + 2), Cells(nR, nC + 17)).Value = Worksheets(1).Range(Cells(i, 14), Cells(i, 29)).Value のようにしたいですが、これもまたエラーが出てしまいます。
- ベストアンサー
- オフィス系ソフト
- 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
お礼
DoEventsを入れたら思うような状態になりました。 ありがとうございました。