マクロで列を挿入してふりがなをふる

全てのシートにあるA列にはいっている漢字を左側に
列を挿入してそこにふりがなをふりたく、
素人なりに下記のソースを書いたんですが、
わけわからんところに挿入されるは無茶苦茶になってしまいました。
どなたか添削していただけないでしょうか？

Sub フリガナ挿入()
Dim ws As Worksheet
Dim r As Range
For Each ws In Worksheets
For Each r In Range("A1", Range("A65536").End(xlUp))
Columns("A").Insert Shift:=xlShiftToLeft
Range("A1" & r.Row).Value = Application.GetPhonetic(r)
Next
Next
End Sub

No.1 ベストアンサー 回答者： noname#123709 回答日時： 2009/02/24 17:25

色々方法があるかと思いますが、これでも動きますね。

Sub フリガナ挿入()
Dim ws As Worksheet
Dim r As Range
Dim i As Long
For Each ws In Worksheets
With ws
.Columns("A").Insert Shift:=xlShiftToLeft
For i = 1 To .Range("B65536").End(xlUp).Row
.Range("A" & i).Value = Application.GetPhonetic(.Range("B" & i))
Next i
End With
Next
End Sub

この回答へのお礼

動きました、ありがとうございました。
こんな書き方もあるんだなと参考になりました。

お礼日時：2009/02/24 18:30

No.3 回答者： merlionXX 回答日時： 2009/02/25 09:49

こんにちは、merlionXXです。

goo0607さんのコードをちょっと修正するとこんな感じになりますね。

Sub TEST01()
Dim ws As Worksheet
Dim r As Range
For Each ws In Worksheets
With ws '各ワークシートにおいて
.Columns("A").Insert Shift:=xlShiftToLeft 'A列の左に列を挿入
For Each r In .Range("B1", .Range("B65536").End(xlUp)) 'B列（旧A列）のデータについて
If r.Value <> "" Then '空白でなければ
.Range("A" & r.Row).Value = Application.GetPhonetic(r) '新A列にフリガナ
End If
Next r '繰り返し
End With
Next ws '繰り返し
End Sub

なお、解決した質問はちゃんと締め切ってくださいね。
http://okwave.jp/qa4733370.html

この回答へのお礼

ありがとうございました、締め切りました。

お礼日時：2009/02/25 16:08

No.2 回答者： hige_082 回答日時： 2009/02/24 17:57

修正してみました

Sub フリガナ挿入()
Dim ws As Worksheet
Dim r As Range
For Each ws In Worksheets
ws.Columns("B").Insert Shift:=xlShiftToLeft　'シート名追加、列をＢ列の前に挿入に変更
For Each r In ws.Range("A1", ws.Range("A65536").End(xlUp))
'Columns("A").Insert Shift:=xlShiftToLeft　'この行は削除、上に移動
ws.Range("B" & r.Row).Value = Application.GetPhonetic(r.Value)　'シート名追加、一部修正
Next
Next
End Sub

Sheetが指定されていなかったので、指定しました
列挿入の位置が、Ａ列、Ｂ列の間であればＢ列を指定しなければいけない
列挿入の実行位置が悪かったので修正

この回答への補足

ありがとうございます。
挿入する場所はA列の左になります。このサンプルですとA列の右側に挿入されます、以下のB部分をAに変更するとAのセルが空白になってしまいました。

ws.Columns("B").Insert Shift:=xlShiftToLeft　'シート名追加、列をＢ列の前に挿入に変更
ws.Range("B" & r.Row).Value = Application.GetPhonetic(r.Value)　'シート名追加、一部修正

補足日時：2009/02/24 18:26