Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
320 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【76027】Re:（Excel2003）検索後、ListBoxに行抽...
発言  kanabun  - 14/8/24(日) 21:35 -
引用なし
パスワード
   ▼くら さん：

>Sheet2に商品名、型番、機番、商品コードを約500行ほど入力しております。
>Sheet1にフォームコントロールボタンを描写し、このボタンを押すと検索窓(TextBox1,CommandButton1,ListBox1)が開くかんじです。
>ここからTextBox1に商品名（A列）または商品コード（D列）の一部を全角で入力し、CommandButton1を押すとSheet2を参照し、一部でも合致した行に含まれる4列のデータすべてをListBox1に抽出表示したいというわけです。部分合致なので複数行の表示を想定し、ListBox1は横長となっています。

> >Sheet1にフォームコントロールボタン

と書いてあるのに、あっち向いてホイッ のような発言で申し訳ないのですが、
フォームコントロール ではなく ユーザーフォーム でのたたき台です。

以下は UserForm1のコードです。
メニュ−[挿入]-[UserFormの挿入]でUserForm1を挿入し、
そこに

　TextBox1
　CommandButton1
　ListBox1

を配置して お試しください。

'-----------------------------------------------------------
Option Explicit
Private FRange As Range　　　 'FilterRange
Private WkSheet As Worksheet　'作業シート（非表示）

Private Sub UserForm_Initialize()
　　Set FRange = Worksheets(2).[A1].CurrentRegion
　　On Error Resume Next
　　Set WkSheet = Worksheets("Temp")
　　On Error GoTo 0
　　If WkSheet Is Nothing Then
　　　　With Worksheets
　　　　　　Set WkSheet = .Add(After:=.Item(.Count))
　　　　End With
　　　　WkSheet.Visible = xlSheetHidden
　　End If
　　ListBox1.ColumnCount = 4
End Sub

Private Sub CommandButton1_Click()
　Dim ss As String
　Dim col As Long
　　ss = TextBox1.Text
　　If Len(ss) < 1 Then Exit Sub
　　If IsNumeric(ss) Then col = 4 Else col = 1
　　FRange.AutoFilter col, "*" & ss & "*"
　　If FRange.Columns(1).SpecialCells(xlVisible).Count > 1 Then
　　　　WkSheet.UsedRange.Clear
　　　　Intersect(FRange, FRange.Offset(1)).Copy WkSheet.[A1]
　　　　ListBox1.List = WkSheet.[A1].CurrentRegion.Value
　　End If
　　FRange.AutoFilter
End Sub
・ツリー全体表示
【76026】（Excel2003）検索後、ListBoxに行抽出で...
質問  くら  - 14/8/24(日) 21:11 -
引用なし
パスワード
   マクロとコードを勉強し始めたばかりの初心者です。
状況は以下のとおりです。
Sheet2に商品名、型番、機番、商品コードを約500行ほど入力しております。
Sheet1にフォームコントロールボタンを描写し、このボタンを押すと検索窓(TextBox1,CommandButton1,ListBox1)が開くかんじです。
ここからTextBox1に商品名（A列）または商品コード（D列）の一部を全角で入力し、CommandButton1を押すとSheet2を参照し、一部でも合致した行に含まれる4列のデータすべてをListBox1に抽出表示したいというわけです。部分合致なので複数行の表示を想定し、ListBox1は横長となっています。

この一連の操作のコードが分からず困っています。よろしくお願いします。
・ツリー全体表示
【76025】Re:非表示について
発言  γ  - 14/8/23(土) 21:04 -
引用なし
パスワード
   マクロ記録をとると
ActiveWindow.Visible = False
といったコードが得られます。

その他、ウインドを最小化しておくという方法もあるでしょう。
その場合は、これもマクロ記録で、
ActiveWindow.WindowState = xlMinimized
とわかります。

ユーザーフォームから、他のブックを開くのはどうするんでしょう。
そのためのボタンを作っておくということですか？
・ツリー全体表示
【76024】Re:非表示について
発言  γ  - 14/8/23(土) 12:08 -
引用なし
パスワード
   >そのブックだけを非表示にするには、どのようなプログラムにすれば良いのでしょうか？
バージョンはいくつですか？
2010なら、表示タブのウインドウの「表示しない」をクリックする操作を
マクロ記録してみると、コードは得られると思いますよ。
他のバージョンでも同じような機能があるはずです。
・ツリー全体表示
【76023】非表示について
質問  平社員  - 14/8/23(土) 11:09 -
引用なし
パスワード
   VBAにて、あるブックを起動時にフォームのみ表示して、
いるのですが、そのブックを開いているときは、他のエクセルの
が開けません。

そのブックだけを非表示にするには、どのようなプログラムにすれば良いのでしょうか？

Private Sub Workbook_open()

application.Visible=True

UserForm.Show

End Sub
・ツリー全体表示
【76022】Re:期間の計算
発言  sim  - 14/8/21(木) 11:21 -
引用なし
パスワード
   ▼γ さん：
>こちらは、VBAの質問箱ですので、別のところに質問されたほうが
>よろしいと思います。
>
>なお、質問にあたっては、
>個々の現象から入るのではなく、
>・実行したいことをまず明確にして、
>・そのために自分はこんなことをした、
>・しかしこんなことになってしまう、
>という順序で書いたほうがよろしいでしょう。
>老婆心ながら。

わかりました。ありがとうございます。
・ツリー全体表示
【76021】Re:期間の計算
発言  γ  - 14/8/21(木) 11:09 -
引用なし
パスワード
   こちらは、VBAの質問箱ですので、別のところに質問されたほうが
よろしいと思います。

なお、質問にあたっては、
個々の現象から入るのではなく、
・実行したいことをまず明確にして、
・そのために自分はこんなことをした、
・しかしこんなことになってしまう、
という順序で書いたほうがよろしいでしょう。
老婆心ながら。
・ツリー全体表示
【76020】期間の計算
質問  sim  - 14/8/21(木) 9:39 -
引用なし
パスワード
   お世話になります。
期間の計算についてお尋ねします。
民法にある
「初日不算入の原則」
期間の満了日は、期間が終了する週、月、または年の起算日に応当する日の前日となります
なのですが、
期間の開始日「2014/01/29」…A1　
期間の終了日「2014/5/30」…A2
の場合に下記のような式を書きました。

=DATEDIF(A1,A2,"M")&"."&ABS(DATEDIF(A1,A2,"MD")-1)

これで返る数値が"4.0"となります。
これを"4.1"とするためにはどのような方法がありますか？
どなたかご教授お願いします。
尚、求められた数値を切り上げして"5"とするためにわざわざ小数点にしています。
よろしくお願いします。
・ツリー全体表示
【76019】Re:パスワード生成時に数字１つ(0から9の...
発言  独覚  - 14/8/21(木) 6:53 -
引用なし
パスワード
   ht tp://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14130509349
これもそうかな？
・ツリー全体表示
【76018】Re:パスワード生成時に数字１つ(0から9の...
発言  γ  - 14/8/20(水) 21:33 -
引用なし
パスワード
   まあ、今度は、自分が納得いくまで、とことん質問することですよ。
わかった積もりで先に進まないほうがいい。
・ツリー全体表示
【76017】Re:パスワード生成時に数字１つ(0から9の...
発言  kanabun  - 14/8/20(水) 21:32 -
引用なし
パスワード
   ht tp://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=163646&rev=0

なるほど。これはちょっと ひどい。
・ツリー全体表示
【76016】Re:パスワード生成時に数字１つ(0から9の...
発言  γ  - 14/8/20(水) 20:51 -
引用なし
パスワード
   回答者への参考として。
ht tp://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=163646&rev=0
ht tp://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=163842&rev=0

ちょっとひど過ぎない？
・ツリー全体表示
【76015】Re:パスワード生成時に数字１つ(0から9の...
発言  kanabun  - 14/8/20(水) 20:39 -
引用なし
パスワード
   ▼初心者 さん：

>生成されるパスワードに数字を含めたいのですが、
>どのようにすれば良いでしょうか？


これは
>' 文字種類
>kind = MenuSheet.Range("KIND").Value
>Select Case kind
>
>Case "英字": chars = "abcdefghijkmnpqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
>Case "数字": chars = "0123456789"
>Case "記号": chars = "!#$%&@?\+-_"
>Case Else: chars = "abcdefghijkmnpqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!#$%&@?\+-_"
>
>End Select

文字種類が 「英字」とか「記号」だったら、何回作っても数字は混じって
こないから、文字種類が
>Case Else
のばあいを言ってるんですよね？

そのばあいだったら、数字が入るまでパスワード生成を繰り返せばいいのでは？

　　For j = 1 To num
　　　　password = Space$(cols) 'パスワードの桁数分のスペース
　　　　Randomize
　　　　
　　　　k = 0
　　　　Do
　　　　　　For i = 1 To cols
　　　　　　　　pointer = Int(Rnd * upper) + 1
　　　　　　　　Mid(password, i, 1) = Mid(chars, pointer, 1)
　　　　　　Next
　　　　　　k = k + 1
　　　　Loop Until password Like "*#*"
　　　　
　　　　With PasswordSheet.Cells(j + 1, 1)
　　　　　　.Range("A1").Value = j
　　　　　　.Range("B1").Value = password
　　　　　　.Range("C1").Value = k　 '参考のため 繰り返した回数
　　　　End With
　　　　　　
　　Next
・ツリー全体表示
【76014】パスワード生成時に数字１つ(0から9のい...
質問  初心者  - 14/8/20(水) 20:03 -
引用なし
パスワード
   パスワード生成時に必ず数字を含めてパスワードを生成したい

下記マクロで実行しておりますが、生成されるパスワードに数字が含まれない場合があります&#160;
生成されるパスワードに数字を含めたいのですが、
どのようにすれば良いでしょうか？
ご教授下さい

EXCEL2010を利用しております

Sub Macro1()
Const DEFAULT_COLS = 8 ' パスワードの桁数
Const DEFAULT_NUM = 1 ' パスワードの個数
Dim cols As Integer
Dim num As Integer
Dim chars As String, password As String
Dim upper As Integer, pointer As Integer, i As Integer

Set MenuSheet = Worksheets("MENU")
Set PasswordSheet = Worksheets("password")

' パスワードの桁
cols = MenuSheet.Range("COLS").Value
If cols < 1 Then
cols = DEFAULT_COLS
End If

' パスワードの個数
num = MenuSheet.Range("NUM").Value
If num < 1 Then
num = DEFAULT_NUM
End If

' 文字種類
kind = MenuSheet.Range("KIND").Value
Select Case kind

Case "英字": chars = "abcdefghijkmnpqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Case "数字": chars = "0123456789"
Case "記号": chars = "!#$%&@?\+-_"
Case Else: chars = "abcdefghijkmnpqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!#$%&@?\+-_"

End Select
upper = Len(chars)

PasswordSheet.Activate
PasswordSheet.Range("A:B").ClearContents ' 前回の結果を消去
PasswordSheet.Range("A1").Value = "No."
PasswordSheet.Range("B1").Value = "パスワード"

For j = 1 To num
password = ""
Randomize
For i = 1 To cols
pointer = Int(Rnd * upper) + 1
password = password + Mid(chars, pointer, 1)
Next

PasswordSheet.Cells(j + 1, 1).Value = j
PasswordSheet.Cells(j + 1, 2).Value = password

Next


End Sub

最後まで見てくださりありがとうございました
宜しくお願い申し上げます
・ツリー全体表示
【76013】Re:別シートの値と比較し、削除、追加を...
お礼  MARUMO  - 14/8/18(月) 21:59 -
引用なし
パスワード
   ▼kanabun さん：
>▼MARUMO さん：
>
>>>1. SheetA の複製を作り（SheetA'とする）
>>>2. SheetBの型番を上から順に見ていって SheetA'になかったら、
>>>　　SheetA'の最終行+1行にコピーして追加。
>>>3. 最後にもとのSheetB を削除して SheetA' を SheetB に改名。
>
>参考まで（というか、自分のメモ）です。
>
>Sub Try3()
>　　Dim newBook As Workbook
>　　Dim A As Worksheet
>　　Dim B As Worksheet
>　　Dim r As Range, q As Range, c As Range
>　　
>　　Set B = Worksheets("db")
>　　Worksheets("wk").Copy　　　 '複製を作成(newBook)
>　　Set newBook = ActiveWorkbook
>　　Set A = newBook.Worksheets(1)
>　　With A
>　　　　Set q = .Cells(.Rows.Count, "D").End(xlUp) '最終セル
>　　　　Set r = .Range("D2", q)
>　　　　Set q = q.EntireRow.Range("A1")
>　　End With
>　　'[B]の型番が[A]になければ [A]の最終行＋1に追加Copyする
>　　For Each c In B.Range("D2", B.Cells(Rows.Count, "D").End(xlUp))
>　　　　If WorksheetFunction.CountIf(r, c) = 0 Then
>　　　　　　Set q = q.Offset(1)
>　　　　　　c.EntireRow.Copy q
>　　　　End If
>　　Next
>　　'このあと newBookに名前をつけて保存
>　　
>End Sub
ありがとうございます。
今後の為に、参考させていただきます。
大変お世話になりました。
・ツリー全体表示
【76012】Re:別シートの値と比較し、削除、追加を...
発言  kanabun  - 14/8/18(月) 18:59 -
引用なし
パスワード
   ▼MARUMO さん：

>>1. SheetA の複製を作り（SheetA'とする）
>>2. SheetBの型番を上から順に見ていって SheetA'になかったら、
>>　　SheetA'の最終行+1行にコピーして追加。
>>3. 最後にもとのSheetB を削除して SheetA' を SheetB に改名。

参考まで（というか、自分のメモ）です。

Sub Try3()
　　Dim newBook As Workbook
　　Dim A As Worksheet
　　Dim B As Worksheet
　　Dim r As Range, q As Range, c As Range
　　
　　Set B = Worksheets("db")
　　Worksheets("wk").Copy　　　 '複製を作成(newBook)
　　Set newBook = ActiveWorkbook
　　Set A = newBook.Worksheets(1)
　　With A
　　　　Set q = .Cells(.Rows.Count, "D").End(xlUp) '最終セル
　　　　Set r = .Range("D2", q)
　　　　Set q = q.EntireRow.Range("A1")
　　End With
　　'[B]の型番が[A]になければ [A]の最終行＋1に追加Copyする
　　For Each c In B.Range("D2", B.Cells(Rows.Count, "D").End(xlUp))
　　　　If WorksheetFunction.CountIf(r, c) = 0 Then
　　　　　　Set q = q.Offset(1)
　　　　　　c.EntireRow.Copy q
　　　　End If
　　Next
　　'このあと newBookに名前をつけて保存
　　
End Sub
・ツリー全体表示
【76011】Re:別シートの値と比較し、削除、追加を...
お礼  MARUMO  - 14/8/18(月) 16:09 -
引用なし
パスワード
   ▼kanabun さん：
>▼MARUMO さん：
>
>>SheetAの方は、型番が複数存在するイメージで
>>書いてしまってました。
>>今の所、同じ型番が複数行になる見込みだそうです。
>>（すみません。先程わかりました）
>
>> 1.SheetBに同じ型番がみつかれば、SheetBからすべて削除
>> 2.SheetAの2行目から最終行までをSheetBの最終行+1
>> に貼り付け。
>
>この処理は
>
>1. SheetA の複製を作り（SheetA'とする）
>2. SheetBの型番を上から順に見ていって SheetA'になかったら、
>　　SheetA'の最終行+1行にコピーして追加。
>3. 最後にもとのSheetB を削除して SheetA' を SheetB に改名。
>
>と同じことだと思うけど？
>そうなら、後者の方法のほうが作業量が少ない（行削除しない）ので
>効率的ですよね？

15:11の補足です。
非常に助かりました。
ありがとうございました。
・ツリー全体表示
【76010】Re:別シートの値と比較し、削除、追加を...
発言  MARUMO  - 14/8/18(月) 15:11 -
引用なし
パスワード
   ▼kanabun さん：
>▼MARUMO さん：
>
>>SheetAの方は、型番が複数存在するイメージで
>>書いてしまってました。
>>今の所、同じ型番が複数行になる見込みだそうです。
>>（すみません。先程わかりました）
>
>> 1.SheetBに同じ型番がみつかれば、SheetBからすべて削除
>> 2.SheetAの2行目から最終行までをSheetBの最終行+1
>> に貼り付け。
>
>この処理は
>
>1. SheetA の複製を作り（SheetA'とする）
>2. SheetBの型番を上から順に見ていって SheetA'になかったら、
>　　SheetA'の最終行+1行にコピーして追加。
>3. 最後にもとのSheetB を削除して SheetA' を SheetB に改名。
>
>と同じことだと思うけど？
>そうなら、後者の方法のほうが作業量が少ない（行削除しない）ので
>効率的ですよね？

沢山のアドバイスありがとうございます。
データの持ち方、正しい処理を行ううえでは
おっしゃる通りなのですが、
今回のデータについては、少し特殊と言いますか・・・
ファイルを使っている方に確認をしたところ、
データは置き換えでいいとの事でしたので
あれから、なんとか下記までたどり着けました。

（↓シート名等は変更しております。）

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim r As Long

Set ws1 = Sheets("db")'SheetB
Set ws2 = Sheets("wk")'SheetA

’同じ型番があれば削除
lastRow = ws1.Range("D" & Rows.Count).End(xlUp).Row
For r = lastRow To 2 Step -1
If WorksheetFunction.CountIf(ws2.Columns("D"), ws1.Range("D" & r)) > 0 Then
ws1.Rows(r).Delete
End If
Next

’SheetB(wk)へ追加処理
maxrow1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
maxrow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row

ws2.Select
Range(Cells(2, 1), Cells(maxrow2, 126)).Copy
ws1.Select
Range("A" & maxrow1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
・ツリー全体表示
【76009】Re:別シートの値と比較し、削除、追加を...
発言  kanabun  - 14/8/18(月) 14:44 -
引用なし
パスワード
   ▼MARUMO さん：

>SheetAの方は、型番が複数存在するイメージで
>書いてしまってました。
>今の所、同じ型番が複数行になる見込みだそうです。
>（すみません。先程わかりました）

> 1.SheetBに同じ型番がみつかれば、SheetBからすべて削除
> 2.SheetAの2行目から最終行までをSheetBの最終行+1
> に貼り付け。

この処理は

1. SheetA の複製を作り（SheetA'とする）
2. SheetBの型番を上から順に見ていって SheetA'になかったら、
　　SheetA'の最終行+1行にコピーして追加。
3. 最後にもとのSheetB を削除して SheetA' を SheetB に改名。

と同じことだと思うけど？
そうなら、後者の方法のほうが作業量が少ない（行削除しない）ので
効率的ですよね？
・ツリー全体表示
【76008】Re:別シートの値と比較し、削除、追加を...
発言  kanabun  - 14/8/18(月) 12:20 -
引用なし
パスワード
   ▼MARUMO さん：

>同じ型番が2件(行)以上存在する事もありますので
>SheetAに2行あれば、SheetBが1行だったとしても
>SheetAに2行と置き換えしたいです。
>
それは、むつかしいですよ
「型番」だけで判断すれば、同じ型番があったら、データ作成時期は
ちがうかもしれないけれど、同じデータのはずです。

そもそも[SheetA]になぜ複数の同じ型番が存在するのですか？

さっき言ったように、同じ型番でも出所がちがうとか、区別される項目が
あるのなら、「型番」だけでなく、他と区別できる（その識別できる）項目
を加えて、行を特定しなければならないはずですけど？

もしSheetA に4つの同じ型番データがあったとして、SheetB にある同じ
型番データは SheetAの「どの」データと置き換えるのですか？
あるいは、SheetB に現在ある同じ型番データは SheetA の4つのデータと
みな違う種類のものだとしたら、SheetBのデータを削除することなく、
あらたに SheetAの4つのデータを追加しなければいけないはずです。

SheetA にあるだけ全部 SheetB に「追加」したとして、
次回のときは SheetB に同じ型番が複数存在することになりますけど、
どうやって 対応をつけるんでしょう？
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
320 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free