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

質問

全てのシートにある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 · ベストアンサー

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

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

お礼

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

回答No.3

merlionXX

こんにちは、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

お礼

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

回答No.2

hige_082

修正してみました

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)　'シート名追加、一部修正