Excel VBA質問箱 IV

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

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


9222 / 76732 ←次へ | 前へ→

【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

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

1 hits

【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 発言

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