| |
型が一致しませんと出てしまうのですが
原因わかりません
よろしくお願いします。
以下36128のコピーです
db.csvは本マクロを含むブックと同一フォルダにあるものとします。
これでできます。
'''''''''''''''''以下は標準モジュールに貼り付けて下さい
Sub test()
Dim w As Workbook
Dim flag As Boolean
Sheets("Sheet1").Cells.Clear
Read_CSV
UserForm1.Show
End Sub
Sub Read_CSV()
Dim dat As Variant
Dim rw As Long
Dim vntA() As Variant
'
Open ThisWorkbook.Path & "\db.csv" For Input As #1
rw = 1
Do Until EOF(1)
Line Input #1, dat
ReDim Preserve vntA(1 To rw)
vntA(rw) = Split(dat, ",")
rw = rw + 1
Loop
Close #1
Sheets("Sheet1").Range("A1").Resize(UBound(vntA), UBound(vntA(1)) + 1).Value _ ★ココでエラー発生★
= Application.Transpose(Application.Transpose(vntA))
Erase vntA
End Sub
'''''''''''''''''以下はUserForm1モジュールに貼り付けて下さい
UserForm1にはTextBox1とListBox1とCommandButton1を作ります
Private Sub CommandButton1_Click()
Dim r As Range, FirstCell As Range, rng As Range
Dim vnt As Variant
Dim prow As Long
Dim s As Worksheet
Dim cnt As Long
'
Set s = Sheets("Sheet1")
Set rng = Intersect(s.Range("A:G"), s.UsedRange)
Set r = rng.Find(What:=TextBox1.Text)
If r Is Nothing Then GoTo Exit_sub
Set FirstCell = r
ReDim vnt(0)
vnt(0) = s.Cells(r.Row, 1).Resize(1, 7).Value
prow = r.Row '同じ行かチック
cnt = 1
Do
Set r = s.UsedRange.FindNext(r)
If Not r Is Nothing And (r.Address <> FirstCell.Address) _
And (FirstCell.Row <> r.Row) And (prow <> r.Row) Then
ReDim Preserve vnt(UBound(vnt) + 1)
vnt(UBound(vnt)) = s.Cells(r.Row, 1).Resize(1, 7).Value
prow = r.Row
cnt = cnt + 1
End If
Loop While r.Address <> FirstCell.Address
'
If cnt = 1 Then vnt = s.Cells(FirstCell.Row, 1).Resize(1, 7).Value
If cnt > 1 Then vnt = Application.Transpose(Application.Transpose(vnt))
ListBox1.List = vnt
'
Set FirstCell = Nothing
Erase vnt
Exit_sub:
If cnt = 0 Then ListBox1.Clear
Set r = Nothing
Set rng = Nothing
Set s = Nothing
End Sub
Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 7 'ListBox1の列は7列にする
Me.TextBox1.SetFocus
End Sub
|
|
おおい
- 07/1/21(日) 15:31 -
