| |
▼ぶたごりら さん：
ちょっと力技のような気もしますが、想定しておられると思われるレイアウトどおりに
転記したつもりです。
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
|
|
UO3
- 12/11/5(月) 21:13 -
