Excel VBAでアンケート集計をしたいと思い、プログラムを作ったのですが、K列にデータを入れると元々存在していたK列のデータが消えてしまいます。どう修正すればデータが残るのでしょうか？| OKWAVE

EXCEL　VBA　

Excel　VBAで　アンケート集計をしたいと思い、プログラムを作ったのですが、J列までは入力がうまくいくのですが、K列にデータを入れて次の行にデータを入れると　もともと存在していたＫれつのデータが消えてしまします。どう修正すれば　ちゃんとデータが残ってくれるのでしょうか？　誰か教えてください Option Explicit Private Sub UserForm_Initialize() Dim チェックボックス As Control With cboBlood .AddItem "A型" .AddItem "B型" .AddItem "O型" .AddItem "AB型" End With cboBlood.ListIndex = -1 txtNo.Value = WorksheetFunction.Max( _ [Database].Resize(, 1)) + 1 txtNo.Enabled = False txtName.Text = "" optMale.Value = True txtAge.Value = 0 For Each チェックボックス In fraOS.Controls チェックボックス.Value = False Next txtName.SetFocus End Sub Private Sub cmdEntry_Click() Dim 行 As Long Dim 確認 As Integer 確認 = MsgBox("データを登録します。" _ & "よろしいですか?", vbYesNo) If 確認 <> vbYes Then Exit Sub 行 = [Database].Rows.Count + 1 [Database].Cells(行 - 1, 1).EntireRow.Insert [Database].Offset(行 - 1).Resize(1).Copy _ [Database].Cells(行 - 1, 1) [Database].Offset(行 - 1).Resize(1).ClearContents [Database].Cells(行, 1) = txtNo.Value [Database].Cells(行, 2) = txtName.Text If optMale.Value = True Then [Database].Cells(行, 3) = "男性" Else [Database].Cells(行, 3) = "女性" End If [Database].Cells(行, 4) = cboBlood.Text [Database].Cells(行, 5) = txtAge.Value If chkWin.Value = True Then _ [Database].Cells(行, 6) = "○" If chkMac.Value = True Then _ [Database].Cells(行, 7) = "○" If chkLinux.Value = True Then _ [Database].Cells(行, 8) = "○" If chkOther.Value = True Then _ [Database].Cells(行, 9) = "○" If chkOther.Value = True Then _ [Database].Cells(行, 10) = "○" Unload frmNew End Sub Private Sub cmdCancel_Click() Unload frmNew End Sub

２つの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　VBAフォーム　登録ボタンの作成方法

いつもお世話になっています。初めて、Excelのフォームで入力画面を作りました。複数の項目があって、それを最後に[登録]ボタンをクリックで表に入れたいのですが、一度にまとめて実行する方法が分かりません。アドバイスよろしくお願いいたします。 Private Sub cmd_1() Dim i As String If man.Value = True Then ActiveCell = man.Caption End If If woman.Value = True Then ActiveCell = woman.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_2() Dim i As String If man.Value = True Then ActiveCell = Yes.Caption End If If woman.Value = True Then ActiveCell = No.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_downlist() Dim ListNo As Long ListNo = group.ListIndex ActiveCell.Value = group.List(ListNo, i) ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_comment() ActiveCell = comment.Text ActiveCell.Offset(1, -3).Select End Sub

エクセルＶＢＡを教えて下さい

エクセルの表で－ＡＢＣＤＥＦ１年月－－1801 ２－－－－－－３－－－－－－４－－－－－－（－）は空欄でセルＥ１＝１８、Ｆ１＝１とします。コントロールボックスをつかって Private Sub Command登録_Click() Dim d1 As Long Dim d2 As Long Dim ret As Variant Dim FindValue As String Dim TotalAddress As String If Range("E1").Value = "" Or Range("F1").Value = "" Then MsgBox "該当する場所にデータが入っていません。", vbCritical Exit Sub End If d1 = Range("A65536").End(xlUp).Offset(1).Row d2 = Range("B65536").End(xlUp).Offset(1).Row FindValue = """" & Range("E1").Value & Range("F1").Value & """" TotalAddress = Range("A1").Resize(d1).Address & "&" & Range("B1").Resize(d1).Address ret = Evaluate("MATCH(" & FindValue & "," & TotalAddress & ",0)") If IsError(ret) Then Cells(d1, 1) = Range("E1").Value Cells(d2, 2) = Range("F1").Value Else MsgBox "既に同じ組み合せがあります。", vbInformation End If End Sub というものを作ったのですが、Ｅ１＝１８、Ｆ１＝１及びコマンドボタンを別シートに作成し、上記の表への登録をできるようにしたいのですが、なにかいい方法はありませんか？

エクセル　VBA　リストについて

エクセル　VBA　リストについて ComboBox3が例えばAなら ComboBox5にリストを入れたい同じBookにSheet”masuta"がありそこに U1　V1　W1　X1 A　　B　C　　D U列の下には”A"があり、Aの項目を入れ込んでいます。 ComboBox３が”A”と表示させた場合 ComboBox５はU列のU３以降の項目が入るようにしたいのですが Set wbMyBook = Workbooks(strMyBookName)エラー表示され型の一致がしないと表示されます！このBookの格納はしているつもりなのですが上手く回避できません教えて下さい。それと下の記述をどのように変化させれば良いかアドバイスお願いします。 Private Const WBHName = "k2.xls" Private Const SH1Name = "Sheet1" Private Const wsListName = "masuta" Dim lngYcnt_List As Long '使用行を格納 Dim wbMyBook As Workbook 'このブックをセット Dim wsList As Worksheet 'リストシートをセット Dim strMyBookName As String 'このブックの名前を格納 Private Sub ComboBox3_Change() Dim lng As Long '使用するブックとシートをセット Set wbMyBook = Workbooks(strMyBookName) Set wsList = wbMyBook.Worksheets(wsListName) 'リストシートの使用行を格納 lngYcnt_List = wsList.Range("masuta!U1:X1").CurrentRegion.Rows.Count 'コンボボックスComboBox1のクリア・フラグをfalseにする。 ComboBox5.Clear flag = False '同じ数字のもののコンボボックスComboBox1に追加。 For lng = 1 To lngYcnt_List If ComboBox3.Value = wsList.Cells(lng, 21) Then 'ComboBox1,TextBox8,呼吸具体策に表示する。 ComboBox5.AddItem wsList.Cells(lng, 21) End If If ComboBox3.Value = wsList.Cells(lng, 22) Then ComboBox5.AddItem wsList.Cells(lng, 22) End If If ComboBox3.Value = wsList.Cells(lng, 23) Then ComboBox5.AddItem wsList.Cells(lng, 23) '処理を抜けるExit For flag = True End If Next lng End Sub

エクセル　VBA　for文について

再び失礼します。昨日VBAを始めた初心者です。 1、チェックボタン17個にそれぞれ変数を設定 2、２つだけチェックを入れると仮定して、実行ボタンを押したときにチェックが入っている2つの中で変数の大きいものをMax、小さいものをMinとしてシートに出力したいのですが、”ここ”と書いてあるところに Me("hensuu" & n). hensuu & n など入れてみたのですがエラーになります。くだらないミスだと思いますがよくわかりません。どなたかご教授お願いします。 Private Sub CommandButton2_Click() If Check1.Value = True Then hensuu1 = "9" End If If Check2.Value = True Then hensuu2 = "8" End If If Check3.Value = True Then hensuu3 = "7" End If If Check4.Value = True Then hensuu4 = "6" End If If Check5.Value = True Then hensuu5 = "5" End If If Check6.Value = True Then hensuu6 = "4" End If If Check7.Value = True Then hensuu7 = "3" End If If Check8.Value = True Then hensuu8 = "2" End If If Check9.Value = True Then hensuu9 = "1" End If If Check11.Value = True Then hensuu10 = "1/2" End If If Check11.Value = True Then hensuu11 = "1/3" End If If Check12.Value = True Then hensuu12 = "1/4" End If If Check13.Value = True Then hensuu13 = "1/5" End If If Check14.Value = True Then hensuu14 = "1/6" End If If Check15.Value = True Then hensuu15 = "1/7" End If If Check16.Value = True Then hensuu16 = "1/8" End If If Check14.Value = True Then hensuu17 = "1/9" End If Dim n As Long Dim Max As Long Dim Min As Long For n = 1 To 17 If Me("Check" & n).Value = True Then Max = ”ここ” If Me("Check" & n).Value = True Then Exit For Next n For n = Max To 17 If Me("Check" & n).Value = True Then Min = ”ここ” If Me("Check" & n).Value = True Then Exit For Next n Worksheets("Sheet1").Range("A1") = Min Worksheets("Sheet1").Range("B1") = Max MsgBox hensuu End Sub

エクセルVBA　VLOOKUPについて

エクセル　VBA初心者です。関数でのVLOOKUPをVBAで作りたいのですが、上手くいきません。あらかじめ、Sheet2の1から300行までに A列　 / B列商品名 / 商品コードが入力されています。(名前の定義=商品コード) Sheet1にユーザーフォームを利用して、データを書き込んだ後、 B列に商品名が書き込まれると、 A列に商品コードが表示されるようにしたいと考えています。 A列に =IF(B2="","",VLOOKUP(B2,商品コード,2,FALSE)) と入力していたのですが、 VBAでIfを使って出来ないかと考えてみたのですが、上手くいきませんでした。 Private Sub Worksheet_Change(ByVal Target As Range) Dim sRow As Long Dim sColumn As Long sRow = ActiveCell.Row sColumn = ActiveCell.Column If Cells(sRow, 2).Value = True Then Cells(sRow, 1).Value = WorksheetFunction.VLookup(Cells(sRow2).Value, Worksheets("Sheet2").Range("A1:B300"), 2, False) ElseIf Cells(sRow, 2).Value = " " Then Cells(sRow, 1).Value = " " End If End Sub ご教授いただけないでしょうか？エクセル2003 WindowsXP

Excel VBAでIF～Thenの入れ子がうまくできません。

いつもお世話になってます。 IF～Then～EndIfにIFを入れていますがうまくいきません。よろしくお願いします。 Private Sub CommandButton10_Click() Dim i As Long Dim 最終行 As String Dim サーチ行 As Long Dim 行 As Long Dim 列 As Long If TextBox33.Value = "" Then MsgBox "使用量を入力してください。" Else If TextBox11 <> "" Then TextBox26 = TextBox33 * TextBox11 / 100 '成分1 End If If TextBox12 <> "" Then TextBox25 = TextBox33 * TextBox12 / 100 '成分2 End If Workbooks.Open Filename:=ThisWorkbook.Path & "\データ物質試薬管理.xls" Sheets("shinki").Activate 最終行 = (Range("B2").End(xlDown).Row) '商品名の行検索サーチ行 = 0 For i = 2 To 最終行 If ComboBox3.Value = Range("B" & i) Then Workbooks("データ物質試薬管理.xls").Close savechanges:=False '保存しない Workbooks.Open Filename:=ThisWorkbook.Path & "\データ物質試薬管理.xls" Sheets("kongou").Select Range("A65536").End(xlUp).Offset(1).Select 行 = ActiveCell.Row 列 = ActiveCell.Column Cells(行, 列) = UserForm11.TextBox16.Value 'CAS Cells(行, 列 + 1) = UserForm11.TextBox21.Value '使用日 Cells(行, 列 + 2) = UserForm11.TextBox29.Value '使用者 Cells(行, 列 + 4) = UserForm11.TextBox26.Value '成分1使用量 Cells(行 + 2, 列) = UserForm11.TextBox18.Value 'CAS Cells(行 + 2, 列 + 1) = UserForm11.TextBox21.Value '使用日 Cells(行 + 2, 列 + 2) = UserForm11.TextBox29.Value '使用者 Cells(行 + 2, 列 + 4) = UserForm11.TextBox24.Value '成分3使用量 Cells(行 + 2, 列 + 5) = UserForm11.TextBox32.Value '種類 Cells(行 + 2, 列 + 6) = UserForm11.TextBox34.Value '単位 Cells(行 + 2, 列 + 7) = UserForm11.ComboBox3.Value '商品名 Workbooks("データ物質試薬管理.xls").Close savechanges:=True 'showhinに在庫管理する Workbooks.Open Filename:=ThisWorkbook.Path & "\データ物質試薬管理.xls" Sheets("showhin").Select Range("A65536").End(xlUp).Offset(1).Select 行 = ActiveCell.Row 列 = ActiveCell.Column Cells(行, 列) = UserForm11.TextBox2.Value '品名コード Cells(行, 列 + 1) = UserForm11.ComboBox3.Value '商品名 'Cells(行, 列 + 2) = UserForm9.TextBox3.Value '１本の量 'Cells(行, 列 + 3) = UserForm9.TextBox4.Value '本数 Cells(行, 列 + 4) = UserForm11.TextBox34.Value '単位 Cells(行, 列 + 5) = UserForm11.TextBox32.Value '種別 Cells(行, 列 + 6) = UserForm11.TextBox21.Value '使用日 Cells(行, 列 + 7) = UserForm11.TextBox29.Value '使用者名 Cells(行, 列 + 9) = UserForm11.TextBox33.Value '使用量 Workbooks("データ物質試薬管理.xls").Close savechanges:=True MsgBox "登録しました。" End If サーチ行 = i Exit For 'End If Next If サーチ行 = 0 Then MsgBox ComboBox3.Value & "商品は登録されておりません。" & Chr(10) & "「新規商品登録」ボタンから入力してください。" End If End If If TextBox21.Value = "" Then '使用量 MsgBox "使用日を入力してください。" End If ComboBox3.SetFocus End Sub

エクセル　マクロ　教えてください。

sheet１に　（a1=No.　b1=月日　C1=項目　d1=収入　e1=支出　f1=摘要　G1=店名）項目を作りそれらをユーザーフォームを作り入力したいです。この記述では上手く動けません。教えてください。 Private Sub CommandButton1_Click() Dim r As Long, 最終行 As Long, 項目行 As Long Dim re As String r = textboxs1.Value + 10 最終行 = Worksheets("入力").Range("B65536").End(xlUp).Row If r <= 最終行 Then re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _ Chr(13) & "データを置き換えます。　本当に良いですか?　", _ Buttons:=vbYesNo + vbExclamation, Title:="注意!!") If re = vbYes Then With Worksheets("入力") .Cells(r, 2).Activate .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = ComboBox2.Value End With データクリア Exit Sub End If データクリア Exit Sub End If If r >= 最終行 + 1 Then r = 最終行 + 1 End If With Worksheets("入力") .Cells(r, 1).Value = TBox1.Value .Cells(r, 2).Value = TBox2.Value .Cells(r, 3).Value = ComboBox1.Value .Cells(r, 4).Value = TBox3.Value .Cells(r, 5).Value = TBox4.Value .Cells(r, 6).Value = TBox5.Value .Cells(r, 7).Value = CBomboox2.Value End With データクリア End Sub r = データNo + 10 With Worksheets("入力") .Activate .Cells(r, 2).Select TBox1.Value = .Cells(r, 1).Value TBox2.Value = .Cells(r, 2).Value ComboBox1.Value = .Cells(r, 3).Value TBox3.Value = Format(.Cells(r, 4).Value, "###,###") TBox4.Value = Format(.Cells(r, 5).Value, "###,###") TBox5.Value = .Cells(r, 6).Value ComboBox2.Value = .Cells(r, 7).Value End With Exit Sub End If If データNo > 最終行 - 10 Then データNo = 最終行 - 9 TBoxNo.Value = データNo データクリア End If End Sub

Excel VBA　リストボックスの複数列表示の方法について

すいません、エクセルVBAのユーザーフォームのリストボックスの表示方法について質問があります。シートのセルに　　 A列　 D列　　　G列 1行りんご　　赤　　　120円 2行　みかん　　黄　　　130円 3行　すいか　　緑 110円 4行　りんご　　赤 160円 . ・・・　　・　　　・・・ . と、50行まで値を入れます。 VBAでユーザーフォームを挿入し、 Private Sub UserForm_Initialize() With ComboBox1 .AddItem "りんご" .AddItem "みかん" .AddItem "すいか" End With End Sub でコンボボックスの値を設定し、次に Private Sub ComboBox1_Change() Dim i As Integer For i = 1 To 50 If Cells(i, 1).Value = ComboBox1.Value Then With ListBox1 .ColumnCount = 3 .AddItem Cells(i, 1) End With End If Next i End Sub このときコンボボックスと同じ値の行について、リストボックスにA列、D列、G列を表示させるにはどうしたらいいのでしょうか。例えばコンボボックスで「りんご」を選択したときに、リストボックスをりんご　赤　120円りんご　赤　160円と表示させたいのですが、 .AddItem Cells(i, 1) では一列だけしか表示できません。 Rowsorceを使ってみたりしましたが、どうにもうまく出来ませんでした。よろしくお願いいたします。

ＶＢＡユーザーフォーム作成のエラーについて

ＶＢＡ初心者です。初心者ですので、本を見ながら作成していましたが、その通り作成したつもりがエラー表示が・・シート上にユーザーフォームは出てくるようにして入力をしているのですが、ボタン（更新、追加、削除）やスピン移動をクリックすると「実行時エラー”424”オブジェクトが必要です”とでてきます。本の通りしたので何が悪かったのかよくわからなくなりました。下記に本を見て作ったコードを書きますので教えて頂きたいです。素人すぎますので説明不足もありますが宜しくお願いします。 Private Sub Button更新_Click() データ書き込み (Spin移動.Value) End Sub Private Sub Button削除_Click() データ範囲.Rows(Spin移動.Value).Delete データ表示 (Spin移動.Value) Set データ範囲 = Range("A1").CurrentRegion Spin移動.Max = データ範囲.Rows.Count End Sub Private Sub Button終了_Click() 患者様データ.Hide End Sub Private Sub Button追加_Click() Dim AddRow As Integer AddRow = データ範囲.Rows.Count + 1　　　←この部分でエラーデータ書き込み (AddRow) Textレコード.Text = Spin移動.Value - 1 & "/" & レコード数取得 Set データ範囲 = Range("A1").CurrentRegion Spin移動.Max = データ範囲.Rows.Count Spin移動.Value = データ範囲.Rows.Count データ表示 (AddRow) End Sub Private Sub MultiPage1_Change() End Sub Private Sub Option女_Click() End Sub Private Sub Option男_Click() End Sub Private Sub Spin移動_Change() If データ範囲.Rows.Count <> 1 Then データ表示 (Spin移動.Value) End If End Sub Private Sub TextIIIIV音_Change() End Sub Private Sub Text患者ID_Change() End Sub Private Sub Text生年月日_AfterUpdate() Text年齢.Value = DateDiff("yyyy", Text生年月日.Value, Now()) End Sub Private Sub UserForm_Initialize() Dim TBL(1 To 9) As Control Dim データ範囲 As Range Combo診療科.ColumnCount = 1 Combo診療科.AddItem "内科" Combo診療科.AddItem "外科" Combo診療科.AddItem "小児科" Combo主治医.ColumnCount = 1 Combo主治医.AddItem "今中尚子" Combo主治医.AddItem "岡井康葉" Set TBL(1) = Text患者ID Set TBL(2) = Text氏名 Set TBL(3) = Text生年月日 Set TBL(4) = Frame性別 Set TBL(5) = Combo診療科 Set TBL(6) = Combo主治医 Set TBL(7) = Text入院日 Set TBL(8) = Text退院日 Set TBL(9) = Combo指導医 Set データ範囲 = Range("A1").CurrentRegion Spin移動.Max = レコード数取得 + 1 If データ範囲.Rows.Count = 1 Then Else データ表示 2 End If End Sub Public Sub データ表示(行数 As Integer) Dim Cnt As Integer For Cnt = 1 To 9 Select Case Cnt Case 4 If データ範囲.Cells(行数, Cnt).Value = "男" Then Option男.Value = True Else Option女.Value = True End If Case Else Dim S For Cnt = 1 To 9 S = データ範囲cells(行数, Cnt).Value Next End Select Next If IsDate(Text生年月日.Text) Then Text年齢.Value = DateDiff("yyyy", Text生年月日.Value, Now()) Else Text年齢.Value = Null End If Textレコード.Value = Spin移動.Value - 1 & "/" & レコード数取得 End Sub Public Sub データ書き込み(行数 As Integer) Dim Cnt As Integer For Cnt = 1 To 9 Select Case Cnt Case 4 If Option男.Value = True Then データ範囲.Cells(行数, Cnt).Value = "男" Else データ範囲.Cells(行数, Cnt).Value = "女" End If Case Else データ範囲.Cells(行数, Cnt).Value = TBL(Cnt).Value End Select Next End Sub Public Function レコード数取得() As Integer レコード数取得 = Range("A1").CurrentRegion.Rows.Count - 1 End Function

EXCEL VBAについて

EXCEL VBAについて教えてくださいやりたいことは以下の通りです。・全シートJ列1～100行目を検索しアルファベットが含まれるセルが存在すれば上のセルをコピーするここまで作ったのですが上手くいきません Sub VBAsample() Dim GYO As Long For GYO = 1 To 100 If Find([a-z], LookAt:=xlPart) Then Cells(GYO, 10).Value = Cells(GYO - 1, 10).Value End If Next GYO End Sub 添削をお願いします

マクロのフォームから。。。

マクロのフォームから。。。マクロのフォームからシートの最終行に入力ができるようにしたいのです。マクロは下記になります。今の状態ですと、新規入力ボタンを押してデータ登録ボタンを押すと、途中の行に登録がされてしまいます。暫く考えていましたがどうしてもわからず、また初心者の為できればわかりやすく教えてもらえると幸いです。どうかよろしくお願い致します。 Private Sub CommandButton3_Click() 入力結果 = MsgBox("データを登録しますか", vbYesNo) If 入力結果 = 6 Then If ToggleButton1.Value = True Then 表示行 = Cells(2, 10).Value + 1 Else 表示行 = Cells(1, 10).Value End If If ToggleButton1.Value = True Then データクリア TextBox1.Value = Cells(表示行, 1).Value + 1 Else データ表示 End If 表示行 = Cells(1, 10).Value Cells(表示行, 1).Value = TextBox1.Value Cells(表示行, 2).Value = TextBox2.Value Cells(表示行, 5).Value = TextBox3.Value Cells(表示行, 6).Value = TextBox4.Value Cells(表示行, 7).Value = TextBox5.Value Cells(表示行, 4).Value = ComboBox1.Value If OptionButton1.Value = True Then Cells(表示行, 3).Value = "男" Else Cells(表示行, 3).Value = "女" End If データ表示 End If End Sub ※　表の範囲：a1:g5(1行目はタイトル) j1:表示行 j2:最終行(counta)

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

エクセル　マクロ

よろしくお願いします。エクセルのテキストに従って勉強していてコード抜けがないことも確認したのですが「ifに対するend ifがありません」と表示されます。デバックを開いてもブレークポイントが表示されていないのでよくわかりません。どこが問題かご享受ください。 Private Sub CommandOK_Click() Dim Row As Integer Row = Range("D1").Value + 3 If 会員登録画面.氏名カナ.Value = Empty Then MsgBox ("氏名カナが空欄です") Exit Sub End If If 会員登録画面.氏名漢字.Value = Empty Then MsgBox ("氏名漢字が空欄です") Exit Sub If Not IsDate(会員登録画面.年.Value & _ "/" & 会員登録画面.月.Value & _ "/" & 会員登録画面.日.Value) Then MsgBox ("生年月日の形式が正しくありません") Exit Sub End If Cells(Row, 1).Value = 会員登録画面.会員番号.Value Cells(Row, 2).Value = 会員登録画面.氏名カナ.Value Cells(Row, 3).Value = 会員登録画面.氏名漢字.Value If 会員登録画面.男.Value = True Then Cells(Row, 4).Value = "男" Else Cells(Row, 4).Value = "女" End If Cells(Row, 5).Value = DateValue(会員登録画面.年.Value & _ "/" & 会員登録画面.月.Value & _ "/" & 会員登録画面.日.Value) Cells(Row, 6).Value = 会員登録画面.都道府県.Value Cells(Row, 7).Value = 会員登録画面.電話番号.Value If 会員登録画面.スポーツ観戦.Value = True Then Cells(Row, 8).Value = "○" End If If 会員登録画面.映画鑑賞.Value = True Then Cells(Row, 9).Value = "○" End If If 会員登録画面.読書.Value = True Then Cells(Row, 10).Value = "○" End If If 会員登録画面.釣り.Value = True Then Cells(Row, 11).Value = "○" End If If 会員登録画面.ドライブ.Value = True Then Cells(Row, 12).Value = "○" End If If 会員登録画面.旅行.Value = True Then Cells(Row, 13).Value = "○" End If Range("D1").Value = Range("D1").Value + 1 Call 画面初期化 End Sub

Excel（VBA）を活用したマクロについて

ExcelのVBAでマクロを作成していますが、プログラムの壁にぶつかってしまいました。恐れ入りますが、ご回答をお願い致します。具体的な作業：３０程度のデータをリストボックスに表示させ、必要なデータを選択してもらうプログラムです（ここまではできています）。選択されたデータは作業者にカラーで確認できるようにしましたが、これらの抽出データをバックアップするために、行列を入れ替え「左から右へ詰めて」別シート（Sheet2)へ貼り付けるにはどうすればよいか、アドバイスをお願いします。お恥ずかしながら、できているところまで掲載させていただきます。 Private Sub データ選択_Click() Dim 数 As Integer If lst一覧.ListIndex = -1 Then 　MsgBox "分析するデータを選択してください" 　lst一覧.SetFocus Else 　For 数 = 0 To lst一覧.ListCount - 1 　　If lst一覧.Selected(数) = True Then 　　　Cells(20 + 数, 23).Resize(, 8).Interior.ColorIndex = 36 　　　Cells(20 + 数, 23).Resize(, 8).Copy 　　　Sheets("Sheet2").Select Range("ここがわかりません").Select 　　　Selection.PasteSpecial 　　　　Paste:=xlPasteFormulas, 　　　　Operation:=xlNone, 　　　　SkipBlanks:=True, 　　　　Transpose:=True 　　　Sheets("Sheet1").Select 　　　Range("A24").Select 　　End If Next 数 End If End Sub

二つの行のうち、どちらかが、セルの値がゼロのとき、その列を非表示にする

二つの行のうち、どちらかが、セルの値がゼロのとき、その列を非表示にする windows7 excelでマクロ作成中の初心者です。以下のコードで27行目のセルの値が0のとき列を非表示にします。 Private Sub 列非表示_Click() Dim 列番号 As Long 'シートが保護されていたら保護を解除 Worksheets("最新明細").Activate If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect End If For 列番号 = 4 To 33 If Cells(27, 列番号).Value = 0 Then Cells(27, 列番号).EntireColumn.Hidden = True End If Next 列番号 ActiveSheet.Protect End Sub ------------------------------------------------- Private Sub 列表示_Click() Dim 列番号 As Long 'シートが保護されていたら保護を解除 Worksheets("最新明細").Activate If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect End If For 列番号 = 4 To 33 If Cells(27, 列番号).Value = 0 Then Cells(27, 列番号).EntireColumn.Hidden = False End If Next 列番号 ActiveSheet.Protect End Sub この27行と、もう一行の28行、どちらかの行が、0のときに列を非表示・表示したいのですが、出来ません。試行錯誤してもできないのです。どうかよろしくおねがいします。 For 列番号 = 4 To 33 If Cells(27, 列番号).Value = 0 or Cells(28, 列番号).Value = 0 Then or( Cells(27, 列番号).EntireColumn.Hidden = True, Cells(27, 列番号).EntireColumn.Hidden = True) End If

ExcelのVBAでコピーのやり方

シート１のAL列の3行目以降の中から0以外の値が入っているAJ列～AN列の行を全てコピーして、シート２のＢ列～Ｆ列に貼り付けたいです。シート２のＢ列～Ｆ列の7行目から下にコピーした値を入れていきたく、値が入っていたらその次の行に貼り付けたいです。例えば、7行目～15行目まで値が入っていたら、16行目から貼り付けるようにしたいです。↓のように書いてみたのですが、コピーしている状態になるだけで、シート2の方へ貼り付けができない状態です。また、オブジェクトが必要ですと表示が出ます。どこをどうなおしたらいいでしょうか。文章がわかりにくく申し訳ありません。回答よろしくお願いいたします。 sub 値をコピー() Dim rTargetRange As Range, ii As Long Set rTargetRange = Nothing For ii = 4 To Cells(Rows.CountLarge, "AL").End(xlUp).Row If (Cells(ii, "AL").Value <> 0) Then If (rTargetRange Is Nothing) Then Set rTargetRange = Cells(ii, "AJ").Resize(, 5) Else Set rTargetRange = Application.Union(rTargetRange, Cells(ii, "AJ").Resize(, 5)) End If End If Next With Worksheets("sheet2") With .Cells(.Rows.CountLarge, "B").End(xlUp) If (.Row = 1 And .Value = "") Then rTargetRange.Copy .Offset(0) Else rTargetRange.Copy .Offset(1) End If End With End With End Sub また、↓のような違ったコードも試しましたが、うまくいきませんでした。 N=Sheet2.Cells(Rows.CountLarge, "AL").End(xlUp).Row+1 SHEET1.SELECT For ii = 4 To Cells(Rows.CountLarge, "AL").End(xlUp).Row If Cells(ii, "AL").Valu e <> 0 Then RANGE("AJ" & ii & ":AN" & ii).COPY SHEET2.RANGE("B" & N) N=N+1 END IF NEXT

エクセル　マクロ　チェックボックス

sheet1にチェックボックスが３つあり、マクロを実行するコマンドボタンが１つあります。チェックボックスにレ点を入れることにより、sheet4のデータからsheet2にグラフを作成しようと考えてますが、エラーが出てしまい解決できません。どのように訂正したらいいのか教えて頂けないでしょうか。 Private Sub CommandButton1_Click() Dim GraphRange As String Dim Graph As ChartObject Dim lastRow As Long Set Graph = Sheets("sheet2").ChartObjects.Add(150, 27, 350, 200) lastRow = Sheets("sheet4").Range("A" & Rows.Count).End(xlUp).Row GraphRange = Sheets("sheet4").Range(Cells(1, 1), Cells(lastRow, 1)).Value If Sheets("sheet1").CheckBox1.Value = True Then 'CheckBox1にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 2), Cells(lastRow, 2)).Value End If If Sheets("sheet1").CheckBox2.Value = True Then 'CheckBox2にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 3), Cells(lastRow, 3)).Value End If If CheckBox3.Value = True Then 'CheckBox3にチェックがあれば GraphRange = Sheets("sheet4").Range(Cells(1, 4), Cells(lastRow, 4)).Value End If Graph.Chart.ChartWizard Source:=Sheets("sheet4").Range(GraphRange).Value, _ Gallery:=xlLine, Format:=1, PlotBy:=xlColumns, _ CategoryLabels:=1, SeriesLabels:=1, HasLegend:=True End Sub

Excel VBAのコンボボックス

お世話になります。コンボボックス1と2と3は選択されますがコンボボックス4には何の表示もされません。選択して条件設定は４つ以上できないのでしょうか？ Dim ITE As Variant Dim flg As Variant Private Sub ComboBox3_Change() 'ComboBox4セット Dim ico As Long ico = 1 With ThisWorkbook.Worksheets("data") KEY = Me.ComboBox1.Text KEY2 = Me.ComboBox2.Text KEY3 = Me.ComboBox3.Text Me.ComboBox4.Clear Do While .Cells(ico, 1) <> "" If .Cells(ico, 1) = KEY And .Cells(ico, 2) = KEY2 And .Cells(ico, 3) = KEY3 Then ITE = .Cells(ico, 4).Value flg = 0 For I = 0 To Me.ComboBox4.ListCount - 1 If ITE = Me.ComboBox4.List(I) Then flg = 1 Next If flg = 0 Then Me.ComboBox4.AddItem ITE End If ico = ico + 1 Loop End With Me.ComboBox4.SetFocus End Sub

Excel VBAでアンケート集計をしたいと思い、プログラムを作ったのですが、K列にデータを入れると元々存在していたK列のデータが消えてしまいます。どう修正すればデータが残るのでしょうか？

EXCEL　VBA

質問者が選んだベストアンサー

お礼 2013/02/17 20:44

補足 2013/02/16 17:54

その他の回答 (1)

お礼 2013/02/17 20:44