こちらの識者の方々にはいつもお世話になっています。
VBAの質問です。
環境は下記になります。
OS=windowsXP SP3
Office=Excel2003(11.8347.8403) SP3
先日、
http://okwave.jp/qa/q8321600.html
で質問した内容なのですが、解決したと思ったらまだ未解決のため、再度質問いたします。
A列に住所のデータがあるのですが、形式がちょっと特殊で、
A1 千代田区千代田1-1-1-301千代田マンション１号棟
A2 千代田区千代田2-3-4
というな形になっています。(A1,A2はセル番地表示で、その文字列がセルにあるわけではありません)
並び順が、市名（区名）・町名・丁目・番地・号地・部屋番号・物件名となっています。
データの定義は、丁目・番地・号地・部屋番号については半角数字・市名（区名）・町名・物件名は数字やアルファベットを含むものであっても全角であることは担保されております。
戸建てであればいいのですが、集合住宅の場合、物件名と部屋番号が入れ替わってしまっています。
これを、できればA列には住所、B列には物件名・（全角スペース）・部屋番号とわけたいのです。
A B
1 千代田区千代田1-1-1 千代田マンション１号棟 301
2 千代田区千代田2-3-4
という内容で、ご回答いただいた
Sub SplitAddresses()
Dim i As Long, n As Integer, pos1 As Integer, pos2 As Integer, pos3 As Integer
For i = 1 To Cells(Rows.Count, "a").End(xlUp).Row
With Cells(i, "a")
For n = 0 To 9
pos1 = InStrRev(.Value, n)
If pos2 < pos1 Then pos2 = pos1
Next n
Cells(i, "b").Value = Right$(.Value, Len(.Value) - pos2)
.Value = Left$(.Value, pos2)
pos2 = 0
pos3 = InStrRev(.Value, "-")
If pos3 And Cells(i, "b").Value <> "" Then
Cells(i, "b").Value = Cells(i, "b").Value & " " & Right$(.Value, Len(.Value) - pos3)
.Value = Left$(.Value, pos3 - 1)
End If
End With
Next i
Columns("a:b").AutoFit
End Sub
というコードでうまくいくと思ったのですが、
千代田区千代田1-2-3-4F千代田マンション１号棟
千代田区千代田1-1-1-A千代田マンション１号棟
といったデータも存在し、For n = 0 To 9ではまかなえないことがわかりました。
（数字の部屋番号だけではなく、4FやAなど、アルファベットの部屋番号が存在するということです）
数字だけではなく、半角英数字を末尾から検査し、その文字列がある位置を割り出す必要があるのですが、InStrRev関数とLike演算子を組み合わせて、返り値をpos1に代入しようと思ったもののうまくいきません。
ひとまず、返り値の確認のため、下記のようなコードを書きましたが、
Cells(1, 2) = InStrRev(Cells(1, 1), Like "*[0-z]*")
というコードは通らず、
Cells(1, 2) = InStrRev(Cells(1, 1), Cells(1, 1) Like "*[0-z]*")
というコードは返り値が0になってしまいます。
上記のような場合、どのようなコードが適していますでしょうか。
質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。
すでに入力規則はリストで使用しております。
そのためVBAで重複入力の排除を行おうと思います。
一応以下のコードでできたのですが、もっと良い方法があったら教えてください。
お願いいたします。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myDic As Object
Dim c As Variant, varData As Variant
Dim i As Long
If Application.Intersect(Target, Range("A1:A50")) Is Nothing Then Exit Sub
Set myDic = CreateObject("Scripting.Dictionary")
varData = Range("A1:A50").Value
For Each c In varData
If Not c = Empty Then
i = i + 1
If Not myDic.Exists(c) Then
myDic.Add c, Null
End If
End If
Next
If myDic.Count < i Then
MsgBox Target & " は重複！"
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
アクセスありがとうございます。
VBA勉強中です。
新しいシートを複数挿入して、そのシート名を指定のものにしたいのですが
そのシート名を一括で指定できないでしょうか？
たとえば、"北海道","青森","秋田"...と47都道府県でシートを新規作成するとして
for i =1 to 47
変数A=（"北海道","青森","秋田"...,"沖縄")
Worksheets.Add
ActiveSheet.Name = 変数A
next i
のような感じで指定できないでしょうか？
上の文はトンチンカンかもしれないんですが…^^;
よくやる作業なので、なんとか簡略化できないかなと思い、
検索してみましたが、検索ワードが悪いのか、まったく出てきませんでした。
どうぞ、よろしくご教授くださいませ…！！！
いつもお世話になります。
WINDOWS7 EXCELL2010 です。
参照図で言うと、
B2 に例えば 1/4 と入力すると 今日の日付になります。
何故なんでしょうか。
影響しているのかどうかわかりませんが参考に下記のようなコードを使用しています。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row >= 2 And Target.Address = Cells(Rows.Count, "C").End(xlUp).Address Then
Target.Offset(0, -1).Value = Date
End If
Dim c As Integer
If Target.Column <> 2 Then Exit Sub
If Target.Value = "" Then
c = 0
Else
On Error GoTo line
Select Case Month(Target.Value)
Case 1: c = 46
Case 2: c = 4
Case 3: c = 39
Case 4: c = 6
Case 5: c = 7
Case 6: c = 8
Case 7: c = 43
Case 8: c = 3
Case 9: c = 44
Case 10: c = 24
Case 11: c = 40
Case 12: c = 17
End Select
End If
Target.Offset(0, -1).Interior.ColorIndex = c
Target.Offset(0, -1).Font.ColorIndex = IIf(c = 1, 2, 0)
Exit Sub
line:
Target.Offset(0, -1).Interior.ColorIndex = 0
Target.Offset(0, -1).Font.ColorIndex = 0
End Sub
いつも回答して頂き、感謝しています。
ネットで調べながら、使えそうな記述を少し修正し、シート削除のマクロを記述してみました。
削除するシートの対象は、別のシートに一覧で載せてあります。
ちなみに、シートを挿入する時も、上記で参照する一覧を参照して作ってあります。
こんな場合もあるから、こんな感じに記述した方がいいよって意見がありましたら、教えてください。宜しくお願い致します。
Sub 作業名別のシートを削除する()
Dim h As Range
On Error Resume Next
Application.DisplayAlerts = False
With Worksheets("作業名一覧")
.Activate
For Each h In .Range(.Range("B2"), Range("B65536").End(xlUp))
Worksheets(h.Value).Delete
Next
End With
Application.DisplayAlerts = True
End Sub
