[[20180314102522]] 『転記先列の指定について』(ねぎ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『転記先列の指定について』(ねぎ)

皆様

お世話になります。ねぎと申します。
現在Aというブックにほかの複数のブックから値を転記するというマクロを作成しております。
その際、Arrayで転記先のブックAの列番号を指定した場合は正常に処理が行われるのですが、ブックA1行目のユニーク値で転記列を指定した際に、
うまく処理されず、エラーが出ます。お力をお貸ししていただけないでしょうか。
ちなみに、デバックでは以下の部分が示されます。
shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value

マクロの具体処理は、ブックAのA列とほかの複数のブックのL39セルに共通のIDがあり、ブックAの共通した値がある行に各値を転記するというものです。
1行目のユニーク値転記先列をで判別する理由としては、列番号で指定していると、今後列を追加削除した際にずれてしますからです。

以上、よろしくお願いいたします。

以下のコードを示します。

Sub 転記()
Const idCol As Long = 1 'ブックAのID列
Const tLine As Long = 1 '列判別ユニーク値

 Dim aryT As Variant, aryA As Variant, colAdr()
 Dim n As Long, mx As Long, cnt As Long
 Dim shT As Worksheet, shF As Worksheet, shW As Worksheet
 Dim idR As Range, f As Range
 Dim fpath As String, fName As String, nfd As String
 Dim dup As Boolean, flg As Boolean

 Application.ScreenUpdating = False

 ThisWorkbook.SaveCopyAs (ThisWorkbook.Path & "\" & _
 Format(Now, "yyyymmdd") & "_" & "bak" & _
 ThisWorkbook.Name)

'aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)  ←このように列番号指定だとうまくいきます。
aryT = Array("136", "137", "138", "139", "140", "142", "143")←このように1行目に入力した文字でやろうとするとエラーが出ます。

 '転記セル
aryA = Array("G12", "A25", "C15", "C16", "C17", "C18 ", "C19", "C20")

 '★転記先シート
Set shT = ThisWorkbook.Sheets("転記先")

 '★ID重複データリスティングシート
Set shW = ThisWorkbook.Sheets("重複データ一覧")
With shT
    If .FilterMode Then .ShowAllData
End With
 shW.Cells.ClearContents
  shT.Rows("1:8").Copy shW.Range("A1")
  mx = shT.Cells(shT.Rows.Count, idCol).End(xlUp).Row

 'AのID範囲を設定
Set idR = shT.Range(shT.Cells(tLine + 2, idCol), shT.Cells(mx, idCol))

 'AでIDが重複している行などを重複データ一覧へ転記
mx = 10
 For Each f In idR
 cnt = WorksheetFunction.CountIf(idR, f.Value)
 If cnt > 1 Or f.Value = 0 Or f.Value = "" Then
 f.EntireRow.Copy Destination:=shW.Rows(mx)
 mx = mx + 1
 dup = True
 End If
 Next f
'ファイルを検索して処理
fpath = ThisWorkbook.Path & "\"
 fName = Dir(fpath & "*.xlsx")
 Do While fName <> ""

 Set shF = Workbooks.Open(fpath & fName).Sheets(1)
 cnt = WorksheetFunction.CountIf(idR, shF.Range("L39").Value)

 flg = False
 If cnt = 1 Then
 If shF.Range("L39").Value <> 0 And shF.Range("L39").Value <> "" Then
 Set f = idR.Find(What:=shF.Range("L39").Value, LookAt:=xlWhole, LookIn:=xlValues)
 If Not f Is Nothing Then
 For n = LBound(aryA) To UBound(aryA)
 shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
 Next n
 flg = True
 End If
 End If
 End If
If Not flg Then
 mx = shW.Cells(shW.Rows.Count, idCol).End(xlUp).Row + 1
 shW.Cells(mx, idCol).Value = fName & " : " & shF.Range("L39").Value
 For n = LBound(aryA) To UBound(aryA)
 shW.Cells(mx, aryT(n)).Value = shF.Range(aryA(n)).Value
 Next n
 nfd = nfd & vbCrLf & fName & " : " & shF.Range("L39").Value
 End If

 shF.Parent.Close False
 fName = Dir()

 Loop

 MsgBox "データを取り込みました。"

End Sub

< 使用 Excel:Excel2013、使用 OS:Windows10 >


 多分ですけど、
 >'aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)  ←このように列番号指定だとうまくいきます。 
なのでもう一つ配列を用意して
ReDim aryTT(LBound(aryT) To UBound(aryT))
MATCHで列番号に変換されてはいかがでしょう? 
For i = LBound(aryT) To UBound(aryT)
    x = Application.Match(aryT(i), Rows(1), 0)
    aryTT(i) = x
Next
(SoulMan) 2018/03/14(水) 10:48

変数aryTは、Cellsの列指定に使っていますね。だったら、136 は136列目でOKですが、文字列指定ならば "EF" 列にしないと駄目かと思いますよ。 "136" は、そのどちらでもないので、エラー。
(???) 2018/03/14(水) 10:51

SoulMan様

ご返信ありがとうございます。
試してみます。

???様

ご返信ありがとうございます。
aryT = Array("EF", "EG", "EH", "EI", "EJ", "EK", "EM")ということでしょうか?

ちなみにこれでもエラーが出ました。
もし、意図を間違えていたらごめんなさい。

(ねぎ) 2018/03/14(水) 11:02


???様
ご返信ありがとうございます。
上記のエラーは間違いです。
正常に動作しました。
ただ、例えばEF列の前に行を挿入した場合その列はEG列になり、ずれてしまいます。
列の追加と削除に追加できるようにはできないでしょうか。。。

(ねぎ) 2018/03/14(水) 11:11


もちろん、列挿入してずれても、コードは変わらないので、処理がおかしくなりますね。

私の場合、辞書オブジェクト(Scripting.Dictionary を調べてみてください)を利用して、セルに書いてある文字列と列番号の対応表を作るロジックを動作させておいて、コード中ではセルの文字列を使ったコーディングにすることで可変対応しています。 例えば、DIC("氏名") = 136 になったとして、使用する際は Cells(mx, DIC("氏名")) とすれば、136列目を見る感じです。 これなら、列挿入されても、辞書を作り直せば追従できますよ。
(???) 2018/03/14(水) 13:11


???様
ご返信ありがとうございます。
なるほど、辞書オブジェクトといものがあるのですね。。。
調べてみたいと思います。

SoulMan様
SoulMan様 にご提示していただいた内容はどこに入れればよいのでしょうか(知識不足で申し訳ございません)。

ReDim aryTT(LBound(aryT) To UBound(aryT))
を上の方に追加し、

For i = LBound(aryT) To UBound(aryT)

    x = Application.Match(aryT(i), Rows(1), 0)
    aryTT(i) = x
Next
の部分は
 For n = LBound(aryA) To UBound(aryA)
 shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
 Next n
を上書きすれば良いのでしょうか。

よろしくお願いします。
(ねぎ) 2018/03/14(水) 13:40


 今日はお休みで外出してました。
ホワイトデーのお返しを買いに行ってました。
そんな個人情報はどうでもええから早よ回答せんかえ! おっさん!
はい!わかりました。

 えぇぇっと、出かける前にぱっと見ただけ、またまた、やらかしている感満載ですけど(;^_^A
 >aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)  ←このように列番号指定だとうまくいきます。 
 >aryT = Array("136", "137", "138", "139", "140", "142", "143")←このように1行目に入力した文字でやろうとするとエラーが出ます。
ですよね?
ここしかみていません。

 なので、一行目のどこかに 136  137  138  139  140  141  142  143
と入力されているんでしょ?

 なので、それを順番に検索してHitした列番号を取得してはいかがですか?
と提案したんです。
わかります。?

 なので、この推論が的外れでしたら、全然、頓珍漢ですから忘れてください。

 Option Explicit
Sub てすと()
Dim x As Variant
Dim aryT As Variant
Dim i As Long
aryT = Array("136", "137", "138", "139", "140", "142", "143")
ReDim aryTT(LBound(aryT) To UBound(aryT))
For i = LBound(aryT) To UBound(aryT)
    x = Application.Match(aryT(i), Rows(1), 0)
    aryTT(i) = x
Next
 '一行目のどこかに 136 137 139 140 142 143
 'と入力されているとしてMatchで検索して実際の列番号を取得します。
 'そうして出来た配列 artTT は
 '>←このように列番号指定だとうまくいきます。
 'になると思うのです。
 'ですから、上手く行く aryT の代わりに使ってください
 '本当はHitしなかった時のことも考えて Iserror(x) などとするのが
 'Betterなのですが、そこはお勉強してください。
 'かなりのスキルがありそうなトピ主さんなので問題ないでしょう
End Sub
v(=∩_∩=)v
(SoulMan) 2018/03/14(水) 15:20

SoulMan様

お忙しい中のご返信ありがとうございます。
まず、このコードの元はここの方に作っていただいたもので、私自身知識はほとんどございません。

「なので、一行目のどこかに 136  137  138  139  140  141  142  143
と入力されているんでしょ?

 なので、それを順番に検索してHitした列番号を取得してはいかがですか?
と提案したんです。
わかります。?
 なので、この推論が的外れでしたら、全然、頓珍漢ですから忘れてください。」

とのことですが、まさしくおっしゃられる通りの処理に改良したいと思っております。
ただ、その内容を実際のコードのどの行に追記すればよいのかがわかりませんでした。。。

元のコードの以下の部分をSoulManさんにご提示していただいた内容で上書きすればよいのかと思いましたが、エラーが出てしましました。

 「For n = LBound(aryA) To UBound(aryA)
 shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
 Next n」

元のコードに組み込むにはどこを書き換えればよいのかご教示していただけないでしょうか。

よろしくお願いします。

(ねぎ) 2018/03/14(水) 16:17


 そこだけ直そうと思いましたが、ちょっと見難いので修正しつつ
検証できないので 感 だけで修正しました。(;^_^A
これで動くといいんですけど、、、、
Option Explicit
Sub 転記()
Const idCol As Long = 1 'ブックAのID列
Const tLine As Long = 1 '列判別ユニーク値
Dim aryT As Variant, aryA As Variant, colAdr()
Dim n As Long, mx As Long, cnt As Long
Dim shT As Worksheet, shF As Worksheet, shW As Worksheet
Dim idR As Range, f As Range
Dim fpath As String, fName As String, nfd As String
Dim dup As Boolean, flg As Boolean
Dim x As Variant
Dim i As Long
Application.ScreenUpdating = False
ThisWorkbook.SaveCopyAs (ThisWorkbook.Path & "\" & _
Format(Now, "yyyymmdd") & "_" & "bak" & ThisWorkbook.Name)
'aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)  ←このように列番号指定だとうまくいきます。
'aryT = Array("136", "137", "138", "139", "140", "142", "143")←このように1行目に入力した文字でやろうとするとエラーが出ます。
'転記セル
aryA = Array("G12", "A25", "C15", "C16", "C17", "C18 ", "C19", "C20")
'★転記先シート
Set shT = ThisWorkbook.Sheets("転記先")
'★ID重複データリスティングシート
Set shW = ThisWorkbook.Sheets("重複データ一覧")
With shT
    If .FilterMode Then .ShowAllData
End With
shW.Cells.ClearContents
shT.Rows("1:8").Copy shW.Range("A1")
mx = shT.Cells(shT.Rows.Count, idCol).End(xlUp).Row
 'AのID範囲を設定
Set idR = shT.Range(shT.Cells(tLine + 2, idCol), shT.Cells(mx, idCol))
 'AでIDが重複している行などを重複データ一覧へ転記
mx = 10
For Each f In idR
    cnt = WorksheetFunction.CountIf(idR, f.Value)
    If cnt > 1 Or f.Value = 0 Or f.Value = "" Then
        f.EntireRow.Copy Destination:=shW.Rows(mx)
        mx = mx + 1
        dup = True
    End If
Next f
'ファイルを検索して処理
fpath = ThisWorkbook.Path & "\"
fName = Dir(fpath & "*.xlsx")
aryT = Array("136", "137", "138", "139", "140", "141", "142", "143")
ReDim aryTT(LBound(aryT) To UBound(aryT))
For i = LBound(aryT) To UBound(aryT)
    x = Application.Match(aryT(i), Rows(1), 0)
    aryTT(i) = x
Next
Do While fName <> ""
    Set shF = Workbooks.Open(fpath & fName).Sheets(1)
    cnt = WorksheetFunction.CountIf(idR, shF.Range("L39").Value)
    flg = False
    If cnt = 1 Then
        If shF.Range("L39").Value <> 0 And shF.Range("L39").Value <> "" Then
            Set f = idR.Find(What:=shF.Range("L39").Value, LookAt:=xlWhole, LookIn:=xlValues)
            If Not f Is Nothing Then

 '                For n = LBound(aryA) To UBound(aryA)
 '                    shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
 '                Next n

                For n = LBound(aryA) To UBound(aryA)
                    shT.Cells(f.Row, aryTT(n)).Value = shF.Range(aryA(n)).Value
                Next n

                flg = True
            End If
        End If
    End If
    If Not flg Then
        mx = shW.Cells(shW.Rows.Count, idCol).End(xlUp).Row + 1
        shW.Cells(mx, idCol).Value = fName & " : " & shF.Range("L39").Value
        For n = LBound(aryA) To UBound(aryA)
            shW.Cells(mx, aryTT(n)).Value = shF.Range(aryA(n)).Value
        Next n
        nfd = nfd & vbCrLf & fName & " : " & shF.Range("L39").Value
    End If
    shF.Parent.Close False
    fName = Dir()
Loop
MsgBox "データを取り込みました。"
End Sub
v(=∩_∩=)v
(SoulMan) 2018/03/14(水) 20:59

わざわざインデントを入れていただきありがとうございます。
  shT.Cells(f.Row, aryTT(n)).Value = shF.Range(aryA(n)).Valueの部分で
型が一致しないというエラーが出ました。
原因を調べてみます!
(ねぎ) 2018/03/14(水) 21:32

 うぅぅん、多分、空 Empty か 文字列 かなぁ????
ちょっと修正してみました。
黄色くDebugしたところにマウスを当てて中身が見れますか?
Option Explicit
Sub 転記()
Const idCol As Long = 1 'ブックAのID列
Const tLine As Long = 1 '列判別ユニーク値
Dim aryT As Variant, aryA As Variant, colAdr()
Dim n As Long, mx As Long, cnt As Long
Dim shT As Worksheet, shF As Worksheet, shW As Worksheet
Dim idR As Range, f As Range
Dim fpath As String, fName As String, nfd As String
Dim dup As Boolean, flg As Boolean
Dim x As Variant
Dim i As Long
Application.ScreenUpdating = False
    ThisWorkbook.SaveCopyAs (ThisWorkbook.Path & "\" & _
        Format(Now, "yyyymmdd") & "_" & "bak" & ThisWorkbook.Name)
    'aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)  ←このように列番号指定だとうまくいきます。
    'aryT = Array("136", "137", "138", "139", "140", "142", "143")←このように1行目に入力した文字でやろうとするとエラーが出ます。
    '転記セル
    aryA = Array("G12", "A25", "C15", "C16", "C17", "C18 ", "C19", "C20")
    '★転記先シート
    Set shT = ThisWorkbook.Sheets("転記先")
    '★ID重複データリスティングシート
    Set shW = ThisWorkbook.Sheets("重複データ一覧")
    With shT
        If .FilterMode Then .ShowAllData
    End With
    shW.Cells.ClearContents
    shT.Rows("1:8").Copy shW.Range("A1")
    mx = shT.Cells(shT.Rows.Count, idCol).End(xlUp).Row
    'AのID範囲を設定
    Set idR = shT.Range(shT.Cells(tLine + 2, idCol), shT.Cells(mx, idCol))
    'AでIDが重複している行などを重複データ一覧へ転記
    mx = 10
    For Each f In idR
        cnt = WorksheetFunction.CountIf(idR, f.Value)
        If cnt > 1 Or f.Value = 0 Or f.Value = "" Then
            f.EntireRow.Copy Destination:=shW.Rows(mx)
            mx = mx + 1
            dup = True
        End If
    Next f
    'ファイルを検索して処理
    fpath = ThisWorkbook.Path & "\"
    fName = Dir(fpath & "*.xlsx")
    aryT = Array("136", "137", "138", "139", "140", "141", "142", "143")
    '配列 aryTT を用意して
    ReDim aryTT(LBound(aryT) To UBound(aryT))
    'aryTの下限から上限までループ
    'Row(1)を検索します
    'Row(1)の前に fName Sheets名を記述した方がよりBetter
    For i = LBound(aryT) To UBound(aryT)
        x = Application.Match(aryT(i), Rows(1), 0)
        'Hitしたら 列番号Indexを取得
        '配列 aryT も aryA も Indexは 8個 なので
        'エラーで回避してもHitしないとエラーになります
        If Not IsError(x) Then aryTT(i) = x
    Next
    Do While fName <> ""
        Set shF = Workbooks.Open(fpath & fName).Sheets(1)
        cnt = WorksheetFunction.CountIf(idR, shF.Range("L39").Value)
        flg = False
        If cnt = 1 Then
            If shF.Range("L39").Value <> 0 And shF.Range("L39").Value <> "" Then
                Set f = idR.Find(What:=shF.Range("L39").Value, LookAt:=xlWhole, LookIn:=xlValues)
                If Not f Is Nothing Then

    '                For n = LBound(aryA) To UBound(aryA)
    '                    shT.Cells(f.Row, aryT(n)).Value = shF.Range(aryA(n)).Value
    '                Next n
                    '以降 aryT は aryTT に書き換えます
                    For n = LBound(aryA) To UBound(aryA)
                        '取り敢えず Val でくくってみました
                        shT.Cells(f.Row, Val(aryTT(n))).Value = shF.Range(aryA(n)).Value
                    Next n

                    flg = True
                End If
            End If
        End If
        If Not flg Then
            mx = shW.Cells(shW.Rows.Count, idCol).End(xlUp).Row + 1
            shW.Cells(mx, idCol).Value = fName & " : " & shF.Range("L39").Value
            'ここも aryT を aryTT に書き換えます
            For n = LBound(aryA) To UBound(aryA)
                '取り敢えず Val でくくってみました
                shW.Cells(mx, Val(aryTT(n))).Value = shF.Range(aryA(n)).Value
            Next n
            nfd = nfd & vbCrLf & fName & " : " & shF.Range("L39").Value
        End If
        shF.Parent.Close False
        fName = Dir()
    Loop
Application.ScreenUpdating = True
MsgBox "データを取り込みました。"
End Sub
v(=∩_∩=)v
(SoulMan) 2018/03/14(水) 22:05

  先ず、x が取得出来ているかですが、
↓これを
x = Application.Match(aryT(i), Rows(1), 0)
↓とか
x = Application.Match(aryT(i), Sheets("Sheet1").Rows(1), 0)
↓他のBookも開いているのならWorkBooks(fName)も付けて
x = Application.Match(aryT(i), WorkBooks(fName).Sheets("Sheet1").Rows(1), 0)
これぐらいした方がいいかもしれません。
(SoulMan) 2018/03/14(水) 22:23

 あっ、わかりました
シートに入力してある数字を検索するのに文字になっていますね
⬇これを
aryT = Array("136", "137", "138", "139", "140", "141", "142", "143")
⬇として
aryT = Array(136, 137, 138, 139, 140, 141, 142, 143)
"を消して下さい
これで動きます
多分???
v(=∩_∩=)v
(SoulMan) 2018/03/14(水) 23:45

ご回答ありがとうございます。
数字に変更したところ、正しく動作しました。ありがとうございます。
本当に助かっております。
ただ、
x = Application.Match(aryT(i), Workbooks(fName).Sheets("Sheet1").Rows(1), 0)

にするとインデックスが有効範囲にないとでました。

ちなみに、
shWの重複データ一覧シートにはブックAのA列のIDが重複している行をまるごとリスティングしていたのですが、書式が崩れています。これは今回の改変の影響なのでしょうか(違っていたらごめんなさい)?
具体的にはshTの1〜9行目(列のタイトル)をコピーし、その下に重複行をコピペする仕様です。

具体的にはブックAのA列には重複値や0、空白があるのですが、それらのときは転記処理をせず、
shWの重複データ一覧シートに行ごと書き出しております。マクロに組み込んでいるのは今後重複やが解消される可能性があり、現在どのデータが重複しているか把握しておくためです。

このあたりのことももしわかれば教えていただけないでしょうか。
以上、よろしくお願いします。

(ねぎ) 2018/03/15(木) 11:02


 動いてよかったです
これは、例ですからね
x = Application.Match(aryT(i), Workbooks(fName).Sheets("Sheet1").Rows(1), 0) 
実際の番号が書かれているシート名にしてださい
後の事は、帰ってからゆっくりとみてみます
(SoulMan) 2018/03/15(木) 11:42

あ、早とちりしてしまいました。
ごめんなさい。

ありがとうございます!!
(ねぎ) 2018/03/15(木) 12:14


動作確認はしてませんが、
以下のように、

Sub test()

    Const cAddress As String = "G12, A25, C15, C16, C17, C18, C19, C20"
    Const cItemName As String = "136, 137, 138, 139, 140, 141, 142, 143"
    Dim rngList As Range
    Dim FPath As String
    Dim FName As String
    Dim wbOld As Workbook
    Dim c As Range
    Dim ixCol As Long
    Dim ixRow As Long
    Dim i As Long
    Dim myItem As Variant
    Dim rngID As Range

    FPath = ThisWorkbook.Path & "\"
    FName = Dir(FPath & "*.xlsx")
    myItem = Split(cItemName, ",")
    Set rngList = ThisWorkbook.Sheets("転記先").UsedRange

    Do While FName <> ""
        Set wbOld = Workbooks.Open(FPath & FName)
        Set rngID = wbOld.Sheets(1).Range("L39")
        For Each c In wbOld.Sheets(1).Range(cAddress).Cells
            i = i + 1
            ixCol = 0
            ixRow = 0
            On Error Resume Next
            With WorksheetFunction
                ixCol = .Match(myItem(i), rngList.Rows(1), 0)
                ixRow = .Match(rngID, rngList.Columns(1), 0)
            End With
            On Error GoTo 0

            With rngList
                If ixCol > 0 Then
                    If ixRow > 0 Then
                        .Cells(ixRow, ixCol).Value = c.Value
                    Else
                        With .Cells(.Worksheet.Rows.Count, 1).End(xlUp).Offset(1)
                            .Cells(1).Value = rngID.Value
                            .Cells(1, ixCol).Value = c.Value
                            Set rngList = rngList.Worksheet.UsedRange
                        End With
                    End If
                End If
            End With
        Next

        wbOld.Close False
        FName = Dir()
    Loop
End Sub

Match関数にて1行目及び1列目を検索して書き込む位置を特定してはいかがでしょうか?

(重複の取り扱いは今回の件に関係ないので割愛しました。)

変数の登場数が多くて煩雑なので自作関数などにまとめて、
処理の流れをすっきりさせたいところですね。。。

サンプルはまともに動かなかったらごめんなさいです。
(まっつわん) 2018/03/15(木) 12:34


 こんばんは!

 >shWの重複データ一覧シートにはブックAのA列のIDが重複している行をまるごとリスティングしていたのですが、
 >書式が崩れています。これは今回の改変の影響なのでしょうか
 >具体的にはブックAのA列には重複値や0、空白があるのですが、それらのときは転記処理をせず、 
 >shWの重複データ一覧シートに行ごと書き出しております。マクロに組み込んでいるのは
 >今後重複やが解消される可能性があり、現在どのデータが重複しているか把握しておくためです。 

 どういう経緯で列を可変にされたのかはわかりませんが、
列を削除されたり追加されればその列の書式は標準または意図されない書式となっている可能性はあるでしょうね
行ごとコピーしているところへ列を削除すると書式が凸凹になる可能性もあるのかもしれませんね?

 >このコードの元はここの方に作っていただいたもので、
 この元のコードは学校で作成されたものらしく出来ればリンクを貼っておきたいです

 また、コードの中にも書式に関する記述はなさそうなので
 元の書式がどの様な書式なのかはわかりませんが、
 記録すれば↓こんなコードが出来ると思います

 Columns("F:F").NumberFormatLocal = "0.00;[赤]0.00"

 ↓それを aryTT(n) で列番号がわかっていますから
For n = LBound(aryA) To UBound(aryA)
  shT.Columns(aryTT(n)).NumberFormat = "0.00"
Next n
とすれば解決出来そうな気もします。

 でも、私がここで取り上げているのはあくまでも 例 ですから
そこは工夫してくださいね。

 それよりもこのコードの中で一番気になるのは、
If Not IsError(x) Then aryTT(i) = x
として エラーではなかったら、、、としていますが
実は、これでは全然意味がなくて、全ての列番号を取得出来なければ、どの道エラーとなるのです。

 なので、
If IsError(x) Then
     MsgBox aryTT(i) & " を検索出来ませんでした。" & vbCrLf & _
              "処理を中止します。"
         Exit Sub
End If
aryTT(i) = x
として処理を中止し、オペレーターに不備があるので列番号を見直してくださいと促すべきだと思います。

 コードを書く人は色んな場面を想定してオペレーターにストレスを与えないコードにしておかないと
使い手が代わった時に使われずに無駄なコードになることも珍しくないですから

 それからここからは気分を悪くなさらないで聞いて欲しいのですが、
質問に対して回答するのは全然苦じゃなくて私の場合、「指が勝手に動く範囲で」お答えしています。

 自分の意志で質問に回答したくて回答しているのです。
でも、質問上手、回答上手ってあると思うのです。

 何が言いたいかと言いますと、ここで得た有益な情報は「多くの人が共有出来る有益な情報」なのです。
つまり、トピが本筋からずれて長くなると回答する側も理解しずらくて、個人⇔個人 になる傾向があると思っています。
私自身も長いトピをみると理解するのに時間がかかりますし、前後の繋がりや流れがわからないのでどうしても回答を
控えることになります。
そうして一番不利益を受けるのは、トピ主さん本人なのです。

 基本的に私は
1.自分の為に回答しています。
2.トピ主さんの為だけに回答しているわけではありません。

 言い方をかえると、私は「お題」が欲しいのです。
 コードって機嫌よく動いている間は書き換える、書き加えることってほとんどないんですよね

 で、あまり長く書かないと指が止まっちゃうんですよね(;^_^A

 それから、こんな私でもわかないことはネットで検索しますし、検索すると学校の自分のトピがHitすることもよくあります。

 つまり、ここでのやり取りはこの場だけのことではないのです。

 何年後か数年後かに他の誰かがネットで検索してHitすることもあるかもしれないのです。

 ですから、ここで得た有益な情報は、不特定多数の人の為にある有益な情報 なのです。

 と、私は思っていて、でも、それをトピ主さんに押し付けるつもりは毛頭もありませんから気にしないでくださいね。

 重複データのところですけど、私の読解力がないのか正直よく分からないです。すみません。
 で、最初にもどりますが、これは、ポイントを絞って別トピを立てられることをお勧めします。

 そうすることで、私以外の有能な方の情報を得ることが出来ますし、何よりもトピ主さんが一番有益な情報を得ることが出来るのです。

 で、トピのタイトルと解決策が 一貫した有益な情報 となるのです。

 つまり 質問上手 となられるのです。

 そのために この学校はある と思ています。みんなが学ぶ場所なのです。

 私は、人様にお教えする様な気持ちは全くなく、自分がこの問題にぶつかった時にどうすかな?と考えて
 自分の為に回答しているのです。
 頓珍漢な回答をすれば鋭い突込みが直ぐに入ります。(^^;

 トピ主さんが躓かれた箇所で他の誰かも躓くかもしれません。
 その時の解決策としてこのトピが残るといいですね。

 で、のちに検索されて誰かの参考になれば素晴らしいとは思いませんか?

 私が主に登校していたのは、2004年ごろです。あれから、、14年????
 変わらずこの場を提供してくださっている校長先生には感謝の気持ちしかありません。

 くれぐれも、トピ主さんが気分を悪くなされずに 質問上手 になられることを願っています。

 長文乱文失礼しました。

 v(=∩_∩=)v
(SoulMan) 2018/03/15(木) 23:33

まっつわん様

回答が遅くなり申し訳ございません。
まだ、見れてないのですが、今後の参考にさせていただきます。

SoulMan様
いろいろとご面倒をお掛けしております。また、SoulMan様の考えについて、承知しました。
自分以外の方のことも考えたいと思います。

重複に関しては考えてうまくいかなければ、改めて質問したいと思います。
いといろとありがとごいざいました。

(ねぎ) 2018/03/16(金) 13:47


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.