| |
こんにちは。かみちゃん です。
>>>下記コードでListBox1の表示が42行目までしか表示しないのですが
>
>sheetにより表示される行数が違います。
>これは外部データのコード.xlsを呼び出しているからでしょうか
>現在のbookにコード.xlsを取り込んだほうがいいのでしょうか？
>コード.xls上でユーザーフォーム3を呼び出した場合は表示されるんですがね
大変申し訳ありません。
[46086]で以下の修正コードを提示させていただいた際に、セル範囲の指定を
誤っています。
以下、[46086]の私の発言内容です。
>すみません。私、間違っていました。
>以下のように★の行を追加してください。
>
>Private Sub UserForm_Initialize()
> Dim ws As Worksheet
>
> Set ws = Workbooks("コード.xls").Sheets("Sheet1")
> With Range("A1", Cells(Rows.Count, 3).End(xlUp))
> Me.ListBox1.ColumnCount = .Columns.Count
> Me.ListBox1.ColumnWidths = "30 pt;50 pt;40 pt"
> ws.Activate '★
> Me.ListBox1.RowSource = .Address
> ThisWorkbook.Activate '★
> End With
>End Sub
最初に提示した[46067]では対応していたのですが、上記の
With Range("A1", Cells(Rows.Count, 3).End(xlUp))
を
With ws.Range("A1", ws.Cells(Rows.Count, 3).End(xlUp))
としていただく必要があります。
>>試行錯誤[46092]夜遅くまでやってみたのですが残念ながら・・・降参です。
>
>であれば、もう、初めから作るしかないのでしょうか(T_T)
ということでお詫びの印に動くと思われるコードを提示させていただきます。
一応、要件とおりにはなっていると思いますが、UserForm3の要件がよくわかりません
'==================================================
'■Sheet5（"発注"）モジュール（[46031]より）
'==================================================
Private Sub Worksheet_BeforeDoubleClick _
(ByVal Target As Range, Cancel As Boolean)
If 1 < Target.Count Then Exit Sub 'If Target.Cells.Count > 1 Then［結合セルはこちら］
On Error Resume Next
If Not Intersect(Target, Range("S8:S107")) Is Nothing Then
Cancel = True
UserForm1.Show vbModeless
Else
UserForm1.Hide
End If
If 1 < Target.Count Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Range("R8:R107")) Is Nothing Then
Cancel = True
UserForm2.Show vbModeless
Else
UserForm2.Hide
End If
End Sub
'==================================================
'■UserForm2モジュール
' （テキスト.txtから検索条件部分一致を選択肢とする）
' （部分一致は全角半角、大文字小文字を無視）
'==================================================
'UserForm初期化処理
Private Sub UserForm_Initialize()
' Dim FName As String
' FName = ThisWorkbook.Path + "C:\テキスト.txt"
' Const cnsFILENAME = "C:\テキスト.txt"
' Dim intFF As Integer
' Dim strREC As String
' Dim GYO As Long
'
' intFF = FreeFile
' Open cnsFILENAME For Input As #intFF
' GYO = 1
' Do Until EOF(intFF)
' Line Input #intFF, strREC
' UserForm2.ListBox1.AddItem strREC
' Loop
'
Me.Left = 150
Me.Top = 100
End Sub
'検索条件を入力後、部分一致するデータをComboBoxへ追加
Private Sub CommandButton1_Click()
' Dim FName As String
Dim cnsFILENAME As String '★
Dim intFF As Integer
Dim strREC As String
Dim GYO As Long
'FName = ThisWorkbook.Path + "C:\テキスト.txt"
'Const cnsFILENAME = "C:\テキスト.txt"
cnsFILENAME = ThisWorkbook.Path + "\テキスト.txt" '★
intFF = FreeFile
Open cnsFILENAME For Input As #intFF
GYO = 1
Do Until EOF(intFF)
Line Input #intFF, strREC
'UserForm2.ListBox1.AddItem strREC
If StrConv(StrConv(strREC, vbWide), vbUpperCase) _
Like "*" & StrConv(StrConv(Me.TextBox1.Value, vbWide), vbUpperCase) & "*" Then
Me.ComboBox1.AddItem strREC '★
End If
Loop
End Sub
'ComboBoxの選択値をアクティブセルへ転記
Private Sub CommandButton2_Click()
ActiveCell.Value = Me.ComboBox1.Value
Unload Me
End Sub
'ComboBoxの選択肢を消去
Private Sub CommandButton3_Click()
Me.ComboBox1.Clear
End Sub
'==================================================
'■UserForm3モジュール
' （コード.xlsから指定範囲すべてを選択肢とする）
'==================================================
'UserForm初期化処理
Private Sub UserForm_Initialize()
Me.Left = 150
Me.Top = 100
End Sub
'コード.xlsのA1セル〜C列の最終列までをComboBoxへ追加
Private Sub CommandButton1_Click()
Dim WB1 As Workbook
Dim WB2 As Workbook
Dim strFileName As String
Dim ws As Worksheet
Set WB1 = ThisWorkbook
strFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
If strFileName <> "False" Then
Application.ScreenUpdating = False
'すでに開いているかどうかをチェックする
If Not ChkWorkbook(Mid(strFileName, InStrRev(strFileName, "\") + 1)) Then
MsgBox strFileName & vbCrLf & "を開きます"
Set WB2 = Workbooks.Open(strFileName)
Else
Set WB2 = Workbooks(Mid(strFileName, InStrRev(strFileName, "\") + 1))
End If
WB1.Activate
Set ws = WB2.Sheets("Sheet1")
With ws.Range("A1", ws.Cells(Rows.Count, 3).End(xlUp))
Me.ComboBox1.ColumnCount = .Columns.Count
Me.ComboBox1.ColumnWidths = "20 pt;20 pt;20 pt"
ws.Activate
'指定範囲の全データをCimboBoxに反映
'（検索条件の部分一致には対応していない）
Me.ComboBox1.RowSource = .Address
WB1.Activate
End With
Application.ScreenUpdating = True
Else
MsgBox "コード.xlsのファイル選択を中止しました"
End If
End Sub
'ComboBoxの選択値をアクティブセルへ転記
Private Sub CommandButton2_Click()
ActiveCell.Value = Me.ComboBox1.Value
Unload Me
End Sub
'ComboBoxの選択肢を消去
Private Sub CommandButton3_Click()
Me.ComboBox1.Clear
End Sub
'ブックオープン済みチェック関数
Function ChkWorkbook(strWorkbookName As String) As Boolean
Dim wb As Workbook
ChkWorkbook = False
For Each wb In Workbooks
If wb.Name = strWorkbookName Then
ChkWorkbook = True
Exit For
End If
Next
End Function
|
|
かみちゃん
- 07/1/23(火) 11:09 -
