Excel VBA質問箱 IV

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

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


1621 / 13646 ツリー ←次へ | 前へ→

【73072】コンボボックスでシート指定して、テキストボックスを反映 ぶたごりら 12/11/5(月) 14:08 質問[未読]
【73073】Re:コンボボックスでシート指定して、テキ... UO3 12/11/5(月) 14:34 発言[未読]
【73074】Re:コンボボックスでシート指定して、テキ... ぶたごりら 12/11/5(月) 14:54 発言[未読]
【73075】Re:コンボボックスでシート指定して、テキ... UO3 12/11/5(月) 15:42 発言[未読]
【73077】Re:コンボボックスでシート指定して、テキ... ぶたごりら 12/11/5(月) 16:47 発言[未読]
【73078】Re:コンボボックスでシート指定して、テキ... UO3 12/11/5(月) 17:06 発言[未読]
【73080】Re:コンボボックスでシート指定して、テキ... ぶたごりら 12/11/5(月) 18:51 発言[未読]
【73081】Re:コンボボックスでシート指定して、テキ... UO3 12/11/5(月) 21:13 発言[未読]
【73082】Re:コンボボックスでシート指定して、テキ... ぶたごりら 12/11/6(火) 15:44 発言[未読]
【73083】Re:コンボボックスでシート指定して、テキ... UO3 12/11/6(火) 17:13 発言[未読]

【73072】コンボボックスでシート指定して、テキス...
質問  ぶたごりら  - 12/11/5(月) 14:08 -

引用なし
パスワード
   以前UO3さんにお手伝いいただき一度は出来たのですが、
今度は書き込むシートをコンボボックスで選択制にして
それぞれ指定したシートに書き込むように変えたのですが、
そしたら1回登録する毎に1行消えてしまうようになりまして。

■ユーザーフォーム
テキストボックス1〜3
指定シート名

■シート3
A列 B列
AAA うめ
AAA
AAA
BBB あめ
CCC こめ
CCC
DDD つめ

とあり、テキストボックスにシート3の「AAA」などを入れ、
指定シート名(コンボボックス)に「シート1」と入れて登録すると
■シート1
A列 B列
AAA うめ
BBB あめ
と出、
指定シート名に「シート2」と入れて登録すると
■シート2
A列 B列
DDD つめ
CCC こめ
に入るようにしたかったのですが。

今ある中身は↓コレ↓になります。
Private Sub CommandButton1_Click()
  Dim s1 As String
  Dim s2 As String
  Dim s3 As String
  Dim sx As Variant
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim i As Long
  Dim wCol As Long
  Dim z As Long
  
  s1 = TextBox1.Value
  s2 = TextBox2.Value
  s3 = TextBox3.Value

  If Len(s1 & s2 & s3) = 0 Then
    MsgBox "抽出すべきキーが入力されていません"
    Exit Sub
  End If
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
 
  If IsEmpty(sh1.Range("A1").Value) Then
    z = 1
  Else
    z = sh1.Range("A" & sh1.Rows.Count).End(xlUp).Row + 1
  End If
  
  sh1.Range("A" & z).Value = sh2.Range("B1").Value
  wCol = sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2
  sh2.Cells(1, wCol) = sh2.Range("A1").Value
 
  i = 2
  For Each sx In Array(s1, s2, s3)
    If Len(sx) > 0 Then
      sh2.Cells(i, wCol).Value = "'=" & sx
      i = i + 1
    End If
  Next
 
  sh2.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=sh2.Cells(1, wCol).CurrentRegion, _
    CopyToRange:=sh1.Range("A" & z), Unique:=False
  If z > 1 Then Rows(z).Delete
  
  sh2.Columns(wCol).Clear
  Application.ScreenUpdating = True
 
End Sub


【73073】Re:コンボボックスでシート指定して、テ...
発言  UO3  - 12/11/5(月) 14:34 -

引用なし
パスワード
   ▼ぶたごりら さん:

こんにちは

1行消えるといった現象の前に、このコード、動いていますか?
このままコピペして、シートの環境も作って動かしてみたんですが
フィルターオプションでエラーになりませんか?
抽出すべきタイトルを検索領域にセットしているところがなく
結果的にどの項目を抽出判定につかうのかということがわからなくなっていますので
1004エラーになるはずですが?

コンボボックスから転記先シートを選ぶということですが
コードの中ではコンボボックスの値は参照していませんし
Sheet1の元ネタからSHeet2に書き込むというコードで
SHeet3のリストから抽出するというコードにもなっていませんが?

アップされたコード、実際のものではないのでは?

【73074】Re:コンボボックスでシート指定して、テ...
発言  ぶたごりら  - 12/11/5(月) 14:54 -

引用なし
パスワード
   ▼UO3 さん:

はい、通常では動いているのですが、
実際のはUO3さんに書いていただきましたのを
少し変えさせていただきまして↓コレ↓になります。

Private Sub コマンド登録_Click()

  Dim SiName As String
  Dim s1 As String
  Dim s2 As String
  Dim s3 As String
  Dim s4 As String
  Dim s5 As String
  Dim s6 As String
  Dim sx As Variant
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim i As Long
  Dim wCol As Long
  Dim z As Long
  Dim k1 As String
  Dim k2 As String
  Dim k3 As String
  Dim k4 As String
  Dim k5 As String
  Dim k6 As String
  Dim LastRow As Long
  Dim Last_Row As Long
  Dim RG As Range

 'コンボボックスで選んだ名前を変数SiNameに格納する
  SiName = コンボ名前.Value
  Worksheets(SiName).Activate

  'E列にコードを略称に変換して入れる
   'G列に数量を入れる
    s1 = テキスト物品コード1.Value
    s2 = テキスト物品コード2.Value
    s3 = テキスト物品コード3.Value
    s4 = テキスト物品コード4.Value
    s5 = テキスト物品コード5.Value
    s6 = テキスト物品コード6.Value
    k1 = テキスト数量1.Value
    k2 = テキスト数量2.Value
    k3 = テキスト数量3.Value
    k4 = テキスト数量4.Value
    k5 = テキスト数量5.Value
    k6 = テキスト数量6.Value

  If Len(s1 & s2 & s3 & s4 & s5 & s6) = 0 Then
    MsgBox "コードは何ですか?"
    Exit Sub
  End If

  Application.ScreenUpdating = False

  Set sh1 = Sheets(SiName)
  Set sh2 = Sheets("コード一覧")

  If IsEmpty(sh1.Range("E1").Value) Then
    z = 1
  Else
    z = sh1.Range("E" & sh1.Rows.Count).End(xlUp).Row + 1
  End If
 
  sh1.Range("E" & z).Value = sh2.Range("B1").Value
  wCol = sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2
  sh2.Cells(1, wCol) = sh2.Range("A1").Value

  i = 2
  For Each sx In Array(s1, s2, s3, s4, s5, s6)
    If Len(sx) > 0 Then
      sh2.Cells(i, wCol).Value = "'=" & sx
      i = i + 1
    End If
  Next

    sh2.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=sh2.Cells(1, wCol).CurrentRegion, _
    CopyToRange:=sh1.Range("E" & z), Unique:=False

  If z > 1 Then Rows(z).Delete
 
  sh2.Columns(wCol).Clear
  Application.ScreenUpdating = True

    LastRow = Range("G" & Rows.Count).End(xlUp).Row
     Range("G" & LastRow + 1).Value = k1
     k1 = ""
    LastRow = Range("G" & Rows.Count).End(xlUp).Row
     Range("G" & LastRow + 1).Value = k2
     k2 = ""
    LastRow = Range("G" & Rows.Count).End(xlUp).Row
     Range("G" & LastRow + 1).Value = k3
     k3 = ""
    LastRow = Range("G" & Rows.Count).End(xlUp).Row
     Range("G" & LastRow + 1).Value = k4
     k4 = ""
    LastRow = Range("G" & Rows.Count).End(xlUp).Row
     Range("G" & LastRow + 1).Value = k5
     k5 = ""
    LastRow = Range("G" & Rows.Count).End(xlUp).Row
     Range("G" & LastRow + 1).Value = k6
     k6 = ""


 'そのシートの有効行数を調べる
   With Worksheets(SiName)
    Range("a65536").End(xlUp).Offset(1).Select
   'C列に受付日を入れる
    Selection.Offset(, 2) = テキスト日付.Value
   'D列に納期を入れる
    Selection.Offset(, 3) = テキスト納期.Value
   End With

   Set RG = ActiveCell
    Range("A" & RG.Row) = Application.WorksheetFunction _
    .Max(Range("A:A")) + 1

 '入力したコントロールの値を初期化します。(元に戻します。)
   テキスト日付.Value = Format(Date, "yyyy/mm/dd")
   テキスト納期.Value = Format(Date + 14, "yyyy/mm/dd")
   テキスト物品コード1 = ""
   テキスト物品コード2 = ""
   テキスト物品コード3 = ""
   テキスト物品コード4 = ""
   テキスト物品コード5 = ""
   テキスト物品コード6 = ""
   テキスト数量1 = ""
   テキスト数量2 = ""
   テキスト数量3 = ""
   テキスト数量4 = ""
   テキスト数量5 = ""
   テキスト数量6 = ""
   コンボ名前 = ""
   テキスト日付.SetFocus

End Sub

よろしくお願いいたします

【73075】Re:コンボボックスでシート指定して、テ...
発言  UO3  - 12/11/5(月) 15:42 -

引用なし
パスワード
   ▼ぶたごりら さん:

再度アップいただいたコードでやってみました。
1行消える消えないということはさておき、コードの

LastRow = Range("G" & Rows.Count).End(xlUp).Row

ここから

Range("A" & RG.Row) = Application.WorksheetFunction.Max(Range("A:A")) + 1

ここまでのコードでは、【どのシート】に何をしているのでしょうか?
とくに、ここで書き込んでいるシートは【どのシート】と想定していますか?

【73077】Re:コンボボックスでシート指定して、テ...
発言  ぶたごりら  - 12/11/5(月) 16:47 -

引用なし
パスワード
   ▼UO3 さん:

お返事ありがとうございます。

>コードの
>
>LastRow = Range("G" & Rows.Count).End(xlUp).Row
>
>ここから
>
>Range("A" & RG.Row) = Application.WorksheetFunction.Max(Range("A:A")) + 1
>
>ここまでのコードでは、【どのシート】に何をしているのでしょうか?
>とくに、ここで書き込んでいるシートは【どのシート】と想定していますか?

シート1やシート2、コンボボックスで指定したシート…を想定してました。
シート1やシート2は管理表となり、シート3はマスタです。
ユーザーフォームで「AAAを2こ、シート2へ書く」として登録すると、
シート2に「あめ 2こ」となるようなイメージでした。。

【73078】Re:コンボボックスでシート指定して、テ...
発言  UO3  - 12/11/5(月) 17:06 -

引用なし
パスワード
   ▼ぶたごりら さん:

>シート1やシート2、コンボボックスで指定したシート…を想定してました。

了解です。コードでは、上のほうで、そのシートをActivateしておられますから
いいといえばいいのですが、前半は、前に私がアップしたコードをベースに
すべてシート修飾(sh1やsh2)されているのに、この部分から以降がシート修飾がないので
奇妙にかんじたんです。
基本的には、この部分でもきちんとシート修飾をしたほうが可読性、今後の保守性で
ベターです。

>シート1やシート2は管理表となり、シート3はマスタです。
>ユーザーフォームで「AAAを2こ、シート2へ書く」として登録すると、
>シート2に「あめ 2こ」となるようなイメージでした。。

このあたり、シート3の記述要領がわからないところがあるのですが以前から気になっていたこととして
たとえば AAA うめ の下に AAA 空白 AAA 空白 と続きますね。
これは何を意味しているのでしょうか?
現在のコードは AAA で抽出しますので、いったんは、この空白の行も抽出されます。
一度の操作で AAA だけを指定すれば、次は、この空白のところを無視して、結果的に連続して
抽出されますが、一回の操作で AAA と BBB を指定しますと、
うめ
空白
空白
あめ
このようになりますよ?

それから、仮にシート3 が
AAA あめ
AAA さめ
AAA 空白
こういったように登録されていれば抽出は
あめ
さめ
になりますね。
一方、ユーザーフォームで AAA に対して 5 といれると
あめ 5
さめ 5
こうなるということでしょうか?

いずれにしても、フィルターオプションで抜き出したものには AAA がないわけで
そこにユーザーフォームで AAA に対して設定した 5 を紐つけて横に転記するには
少し、ロジックが不足だと思います。

今回の1行消える、消えないということとは別物ですが、上でお聞きしている
シート3の登録要領(登録規則)を教えていただければ、全体のコード案も提示させていただくことが
できるかと思います。

【73080】Re:コンボボックスでシート指定して、テ...
発言  ぶたごりら  - 12/11/5(月) 18:51 -

引用なし
パスワード
   ▼UO3 さん:

お返事ありがとうございます。
>>シート1やシート2、コンボボックスで指定したシート…を想定してました。
>
>了解です。コードでは、上のほうで、そのシートをActivateしておられますから
>いいといえばいいのですが、前半は、前に私がアップしたコードをベースに
>すべてシート修飾(sh1やsh2)されているのに、この部分から以降がシート修飾がないので
>奇妙にかんじたんです。
>基本的には、この部分でもきちんとシート修飾をしたほうが可読性、今後の保守性で
>ベターです。
なるほどです。1回書いて満足してしまっておりました。
自分で読み返して解読に時間がかかる内容になってしまってましたので、
ここは書き直したいと思います。


>>シート1やシート2は管理表となり、シート3はマスタです。
>>ユーザーフォームで「AAAを2こ、シート2へ書く」として登録すると、
>>シート2に「あめ 2こ」となるようなイメージでした。。
>
>このあたり、シート3の記述要領がわからないところがあるのですが以前から気になっていたこととして
>たとえば AAA うめ の下に AAA 空白 AAA 空白 と続きますね。
>これは何を意味しているのでしょうか?
>現在のコードは AAA で抽出しますので、いったんは、この空白の行も抽出されます。
>一度の操作で AAA だけを指定すれば、次は、この空白のところを無視して、結果的に連続して
>抽出されますが、一回の操作で AAA と BBB を指定しますと、
>うめ
>空白
>空白
>あめ
>このようになりますよ?
>それから、仮にシート3 が
>AAA あめ
>AAA さめ
>AAA 空白
>こういったように登録されていれば抽出は
>あめ
>さめ
>になりますね。
>一方、ユーザーフォームで AAA に対して 5 といれると
>あめ 5
>さめ 5
>こうなるということでしょうか?

はい、
 A列 B列
 AAA あめ
 AAA うめ
 BBB こめ
 CCC さめ
 CCC きめ
ですが、「AAA」は「あめ」と「うめ」の合体したもので、
「CCC」は「さめ」と「きめ」が合体したものとなり、
【AAAを5こ】と入れたら
 あめ 5
 うめ 5
と表示してほしいです。

>いずれにしても、フィルーオプションで抜き出したものには AAA がないわけで
>そこにユーザーフォームで AAA に対して設定した 5 を紐つけて横に転記するには
>少し、ロジックが不足だと思います。
>
>今回の1行消える、消えないということとは別物ですが、上でお聞きしている
>シート3の登録要領(登録規則)を教えていただければ、全体のコード案も提示させていただくことが
>できるかと思います。

が、そうですよね、フィルターオプションで抜き出したものと整合がとれないですものね。
「AAA」と入れたら「あめ」とだけ出す方が分かりやすいのかもしれないですよね。。

【73081】Re:コンボボックスでシート指定して、テ...
発言  UO3  - 12/11/5(月) 21:13 -

引用なし
パスワード
   ▼ぶたごりら さん:

ちょっと力技のような気もしますが、想定しておられると思われるレイアウトどおりに
転記したつもりです。

Private Sub コマンド登録_Click()

  Dim SiName As String
  Dim sx As Variant
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim i As Long
  Dim wCol As Long
  Dim z As Long
  Dim dic As Object
  Dim x As Long
  Dim f As Range
  Dim c As Range
  
  'コンボボックスで選んだ名前を変数SiNameに格納する
  SiName = コンボ名前.Value
  If Len(SiName) = 0 Then
    MsgBox "シートが選ばれていません"
    Exit Sub
  End If
  '
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To 6
    If Len(Me.Controls("テキスト物品コード" & i).Value) > 0 Then
      dic(Me.Controls("テキスト物品コード" & i).Value) = Me.Controls("テキスト数量" & i).Value
    End If
  Next
  
  If dic.Count = 0 Then
    MsgBox "コードは何ですか?"
    Exit Sub
  End If
      
  Application.ScreenUpdating = False

  Set sh1 = Sheets(SiName)
  Set sh2 = Sheets("コード一覧")

  If IsEmpty(sh1.Range("E1").Value) Then
    z = 1
  Else
    z = sh1.UsedRange.Cells(sh1.UsedRange.Cells.Count).Row + 1
  End If

  sh1.Range("E" & z).Value = sh2.Range("B1").Value
  sh1.Range("F" & z).Value = sh2.Range("A1").Value
  
  wCol = sh2.Cells(1, sh2.Columns.Count).End(xlToLeft).Column + 2
  sh2.Cells(1, wCol).Value = sh2.Range("A1").Value
  i = 2
  For Each sx In dic
    sh2.Cells(i, wCol).Value = "'=" & sx
    i = i + 1
  Next

  sh2.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=sh2.Cells(1, wCol).CurrentRegion, _
    CopyToRange:=sh1.Range("E" & z).Resize(, 2), Unique:=False
    
  Set f = sh1.Range("F" & z).Offset(1)
  If z > 1 Then Rows(z).Delete
  sh1.Range("F1").ClearContents
  sh2.Columns(wCol).Resize(, 2).Clear

  If Len(f.Value) > 0 Then
  
    For Each c In sh1.Range(f, sh1.Range("F" & sh1.Rows.Count).End(xlUp))
      c.EntireRow.Range("G1").Value = dic(c.Value)
      c.EntireRow.Range("B1").Value = テキスト日付.Value
      c.EntireRow.Range("C1").Value = テキスト納期.Value
      c.EntireRow.Range("A1").Value = Application.WorksheetFunction.Max(sh1.Range("A:A")) + 1
      c.ClearContents
    Next
  End If

 '入力したコントロールの値を初期化します。(元に戻します。)
  テキスト日付.Value = Format(Date, "yyyy/mm/dd")
  テキスト納期.Value = Format(Date + 14, "yyyy/mm/dd")
  テキスト物品コード1 = ""
  テキスト物品コード2 = ""
  テキスト物品コード3 = ""
  テキスト物品コード4 = ""
  テキスト物品コード5 = ""
  テキスト物品コード6 = ""
  テキスト数量1 = ""
  テキスト数量2 = ""
  テキスト数量3 = ""
  テキスト数量4 = ""
  テキスト数量5 = ""
  テキスト数量6 = ""
  コンボ名前 = ""
  テキスト日付.SetFocus

  Application.ScreenUpdating = True
  
End Sub

【73082】Re:コンボボックスでシート指定して、テ...
発言  ぶたごりら  - 12/11/6(火) 15:44 -

引用なし
パスワード
   ▼UO3 さん:

お返事ありがとうございます。
が、
  sh2.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, _
    CriteriaRange:=sh2.Cells(1, wCol).CurrentRegion, _
    CopyToRange:=sh1.Range("E" & z).Resize(, 2), Unique:=False
のところでフィールド名がないと言われてしまいました。。

あと、すみません、ちなみになのですが、
UO3さんのおっしゃる「F列」って何をイメージされてますでしょうか?

【73083】Re:コンボボックスでシート指定して、テ...
発言  UO3  - 12/11/6(火) 17:13 -

引用なし
パスワード
   ▼ぶたごりら さん:

こんにちは

まず、こちらで勝手に、元シート(Sheet3)のA列、B列ともに1行目にタイトルがあるという前提にしています。
このあたり、確認しないままコードをアップしています。

たとえば
     A   B
1行目 コード データ
2行目 AAA うめ
3行目 AAA かめ
4行目 CCC こめ
5行目 DDD つめ
といったように。


>UO3さんのおっしゃる「F列」って何をイメージされてますでしょうか?

で、今回の処理なんですが、たとえばユーザーフォームで抽出キーとして
AAA 100
BBB 200
CCC 300
このように指定したとします。

そうすると、フィルターオプションで抽出される結果は

うめ (AAAに紐付いて抽出)
かめ (AAAに紐付いて抽出)
こめ (CCCに紐付いて抽出)

こうなります。
つまり、BBBはデータがないのでそれに基づくものは抽出されません。
で、抽出された うめ、かめ、こめ これらが AAAなのかBBBなのかCCCなのか?
そちらのコードでは、上から順番に 100,200,300とセットしていましたけど、具合悪いですよね。
なので、こっそり F列に元シートのA列の情報を抽出。
その結果は

うめ AAA
かめ AAA
こめ CCC

このようになりますので、各行の うめ、かめ、こめ が、ユーザーフォーム上のどれに関連していたのかが
わかり、したがって、それぞれの数字を紐つけることができるわけで、紐つけた後、こっそりと、一緒に抽出した
AAA とか CCC をクリアしています。

で、このA列も抽出しますので元シートのA1には、それなりのタイトルラベルが必要になります。
ここが空白ということはないでしょうか?

1621 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free