[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『データー元の読み取るセル範囲を拡大したいです』（ちぃさん）
いつもお世話になります。
[[20130502201155]] コチラでご教授いただきましたマクロでデーターの読み取るセル数を増やしたいです。
宜しくお願いします。
マクロコードはご教授いただいたままを使用していまして
Option Explicit
Dim WithEvents xlapp As Application
Dim flag() As String
Dim wbOT As Workbook
Const nameOT As String = "他のBook.xlsx"
Const nameShTo As String = "Sheet1"
Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1"
Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K"
Const copyR3 As String = "A7"
Const nameShFrom1 As String = "Sheet1"
Const nameShFrom2 As String = "Sheet2"
Const nameShFrom3 As String = "Sheet3"
Private Sub Workbook_Open()
Set xlapp = Application
On Error Resume Next 'まだ開かれていなかった場合の対応
Set wbOT = Workbooks(nameOT)
On Error GoTo 0
ReDim flag(1 To 3)
End Sub
Private Sub xlapp_WorkbookOpen(ByVal Wb As Workbook)
If Wb.Name = nameOT Then
Set wbOT = Wb
If wbOT.ActiveSheet.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_WorkbookActivate(ByVal Wb As Workbook)
If Wb.Name = nameOT Then
If Wb.ActiveSheet.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_SheetActivate(ByVal Sh As Object)
If Sh.Parent.Name = nameOT Then
If Sh.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Parent Is ThisWorkbook Then
Select Case Sh.Name
Case nameShFrom1
If Not Intersect(Target, Sh.Range(copyR1)) Is Nothing Then flag(1) = "X"
Case nameShFrom2
If Not Intersect(Target, Sh.Range(copyR2)) Is Nothing Then flag(2) = "X"
Case nameShFrom3
If Not Intersect(Target, Sh.Range(copyR3)) Is Nothing Then flag(3) = "X"
End Select
End If
End Sub
Private Sub CopyLine()
Dim nameF As String
Dim copyR As String
Dim shF As Worksheet
Dim z As Long
Dim x As Long
Dim y As Long
Dim v() As Variant
Dim c As Range
Dim k As Long
Dim shT As Worksheet
Set shT = wbOT.Sheets(nameShTo)
For y = 1 To UBound(flag)
If Len(flag(y)) Then
'転移シートデータ最終行をA列で判断
z = shT.Range("A" & shT.Rows.Count).End(xlUp).Row + 1
nameF = VBA.Array(nameShFrom1, nameShFrom2, nameShFrom3)(y - 1)
copyR = VBA.Array(copyR1, copyR2, copyR3)(y - 1)
With Sheets(nameF).Range(copyR)
x = Range(copyR).Count + 1 'コピーセル数+1
ReDim v(1 To x)
v(1) = Date
k = 1
For Each c In .Cells
k = k + 1
v(k) = c.Value
Next
shT.Range("A" & z).Resize(, x).Value = v
End With
End If
Next
ReDim flag(1 To UBound(flag))
End Sub
現在はこのようになっています。
「データーの読み取るセル数を増やしたい」というのは
Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1"
Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K"
Const copyR3 As String = "A7"
この部分の選択するセルの場所を各150個づつ選択できるようにしたいです。
「各150個」づつというのは
Const copyR1 As String = で "A1:ET1" ではなく "A1,B1,C1〜 ,ET1" という意味です。
copyR2 も copyR3 も copyR1 と同じようにです。
以前、コチラで教えていただきました Unionメソッド を試してみたのですが私の使い方が悪いためか 実行時エラー438 がでます。
Unionメソッド で追加したマクロは
Option Explicit
Dim WithEvents xlapp As Application
Dim flag() As String
Dim wbOT As Workbook
Const nameOT As String = "他のBook.xlsx"
Const nameShTo As String = "Sheet1"
Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1"
Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K"
Const copyR3 As String = "A7"
Const copyR4 As String = "A7"
Const nameShFrom1 As String = "Sheet1"
Const nameShFrom2 As String = "Sheet2"
Const nameShFrom3 As String = "Sheet3"
Private Sub Workbook_Open()
Set xlapp = Application
On Error Resume Next 'まだ開かれていなかった場合の対応
Set wbOT = Workbooks(nameOT)
On Error GoTo 0
ReDim flag(1 To 3)
End Sub
Private Sub xlapp_WorkbookOpen(ByVal Wb As Workbook)
If Wb.Name = nameOT Then
Set wbOT = Wb
If wbOT.ActiveSheet.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_WorkbookActivate(ByVal Wb As Workbook)
If Wb.Name = nameOT Then
If Wb.ActiveSheet.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_SheetActivate(ByVal Sh As Object)
If Sh.Parent.Name = nameOT Then
If Sh.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Parent Is ThisWorkbook Then
Select Case Sh.Name
Case nameShFrom1
If Not Intersect(Target, Sh.Union(Range(copyR1), Range(copyR4))) Is Nothing Then flag(1) = "X"
Case nameShFrom2
If Not Intersect(Target, Sh.Range(copyR2)) Is Nothing Then flag(2) = "X"
Case nameShFrom3
If Not Intersect(Target, Sh.Range(copyR3)) Is Nothing Then flag(3) = "X"
End Select
End If
End Sub
Private Sub CopyLine()
Dim nameF As String
Dim copyR As String
Dim shF As Worksheet
Dim z As Long
Dim x As Long
Dim y As Long
Dim v() As Variant
Dim c As Range
Dim k As Long
Dim shT As Worksheet
Set shT = wbOT.Sheets(nameShTo)
For y = 1 To UBound(flag)
If Len(flag(y)) Then
'転移シートデータ最終行をA列で判断
z = shT.Range("A" & shT.Rows.Count).End(xlUp).Row + 1
nameF = VBA.Array(nameShFrom1, nameShFrom2, nameShFrom3)(y - 1)
copyR = VBA.Array(copyR1, copyR2, copyR3)(y - 1)
With Sheets(nameF).Range(copyR)
x = Range(copyR).Count + 1 'コピーセル数+1
ReDim v(1 To x)
v(1) = Date
k = 1
For Each c In .Cells
k = k + 1
v(k) = c.Value
Next
shT.Range("A" & z).Resize(, x).Value = v
End With
End If
Next
ReDim flag(1 To UBound(flag))
End Sub
このように変更しました。
実行時エラー438 を調べてみると 「コンポーネントが正常に実行されませんでした。」
とありましたが全く意味がわかりません。
非常に解りにくい説明で申し訳ありません。
こちらのマクロコードをどのように追加すれば私が希望するマクロでデーターの読み取るセル数を増やせますでしょうか？
どうかお助けいただけないでしょうか。
何卒宜しくお願い致します。
＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
回答ではないです。
インデントを付けるようにしまでょう。 非常に読みづらいです。 （カリーニン） 2015/01/23(金) 22:23
今後気を付けます。
（ちぃさん） 2015/01/23(金) 22:28
私も回答ではないです 過去ログのリンク間違えていませんか？ [[20130612011339]]
（マナ） 2015/01/23(金) 22:52
１）各範囲にマクロで名前を定義して、例えばcopyR1なら範囲1、copyR2なら範囲2
２）コードは、 range(範囲1)、range(範囲2) とか copyR = VBA.Array(範囲1, 範囲2, 範囲3)(y - 1)
としてら駄目ですかね。
試していません。単なる思いつき。
（マナ） 2015/01/24(土) 10:43
（マナ）さん案の
＞１）各範囲にマクロで名前を定義して、例えばcopyR1なら範囲1、copyR2なら範囲2
＞２）コードは、 range(範囲1)、range(範囲2) とか copyR = VBA.Array(範囲1, 範囲2, 範囲3)(y - 1)
でしたら作り直すイメージでしょうか？
間違っていたらすいません。
できれば今あるマクロを少し変えて使えるのが一番いいのですが（汗）
（カリーニン）さんに指摘されていますが私の書き込み方が悪く非常に読みにくく申し訳ありません。
現在マクロ動作状態は
1つのBookにあるシートの指定したセルに一部でも変更があれば指定したBookに転記されるものです。
Const nameShFrom1 As String = "Sheet1" の Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1"
に一か所でも変化があれば指定したBook(Const nameOT As String = "他のBook.xlsx" の Const nameShTo As String = "Sheet1"
に最下行に転記される状態です。
もし、Const nameShFrom1 As String = "Sheet1" の Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1" にセルの内容に変更がなく
Const nameShFrom2 As String = "Sheet2" の Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K" にセルの変更があれば
Const nameShFrom2 As String = "Sheet2" の Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K" の内容のみ全て転記されます。
もし、Const nameShFrom2 As String = "Sheet2" の Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K" にセルの内容に変更があり、
指定したBook(Const nameOT As String = "他のBook.xlsx" の Const nameShTo As String = "Sheet1"
がまだアクティブになってない状態で
Const nameShFrom1 As String = "Sheet1" の Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1" にセルの内容に変更があれば
指定したBook(Const nameOT As String = "他のBook.xlsx" の Const nameShTo As String = "Sheet1"
がアクティブになった時に
Const nameShFrom2 As String = "Sheet2" の Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K"の内容をすべて転記したのちに
Const nameShFrom1 As String = "Sheet1" の Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1" の内容をすべて転記されるようになっております。
Const nameShFrom1 As String = "Sheet1" の Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1" で選択セル数を150個も指定するのは無理なので
Const copyR4 As String = "A7" を増やし
If Not Intersect(Target, Sh.Range(copyR1)) Is Nothing Then flag(1) = "X"
を
If Not Intersect(Target, Sh.Union(Range(copyR1), Range(copyR4))) Is Nothing Then flag(1) = "X"
に変更したのですがこの部分ではダメなのでしょうか？
それともConstステートメントが使われているから結合は無理ということでしょうか？
わかりにくく申し訳ありません。
どうか宜しくお願いいたします。
（ちぃさん） 2015/01/24(土) 13:33
もしかしてRange前のピリオドがないから？と思い少し変えてみました。
先程までの
If Not Intersect(Target, Sh.Union(Range(copyR1), Range(copyR4))) Is Nothing Then flag(1) = "X"
を
If Not Intersect(Target, Union(Sh.Range(copyR1), Sh.Range(copyR2))) Is Nothing Then flag(1) = "X"
に変更してみたらエラーはでなくなったのですが (copyR1)の内容だけ転記され(copyR2)の内容は転記されません。
何故でしょうか（汗）
お助けいただけないでしょうか。
どうぞ宜しくお願いいたします。
（ちぃさん） 2015/01/24(土) 13:57
(誤)If Not Intersect(Target, Union(Sh.Range(copyR1), Sh.Range(copyR2))) Is Nothing Then flag(1) = "X"
(正)If Not Intersect(Target, Union(Sh.Range(copyR1), Sh.Range(copyR4))) Is Nothing Then flag(1) = "X"
（ちぃさん） 2015/01/24(土) 14:02
１）の名前定義は、転記元ブックに対してマクロで１回だけ実行しておきます。 "範囲1"、"範囲2"、"範囲3"
２）コード変更は、 ＞Const copyR1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1" ＞Const copyR2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K" ＞Const copyR3 As String = "A7" を Const copyR1 As String = "範囲1" Const copyR2 As String = "範囲2" Const copyR3 As String = "範囲3"
に変更するだけでできないかなと考えました。
試してみないとわかりませんが。これがもっとも手軽かなと。
（マナ） 2015/01/24(土) 14:08
Sub 転記元に名前定義()
Const 転記元1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1"
Const 転記元2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K"
Const 転記元3 As String = "A7"
With Workbooks(nameOT)
defName .Sheets(nameShFrom1), 転記元1, "範囲1"
defName .Sheets(nameShFrom2), 転記元2, "範囲2"
defName .Sheets(nameShFrom3), 転記元3, "範囲3"
End With
End Sub
Private Sub defName(ws As Worksheet, Adr As String, myN As String)
Dim v
Dim i As Long
Dim r As Range
v = Split(Adr, ",")
Set r = ws.Range(v(0))
For i = 1 To UBound(v)
Set r = Union(r, ws.Range(v(i)))
Next
r.Name = myN
End Sub
（マナ） 2015/01/24(土) 14:32
１）の名前定義 の案を試してみました。
残念ながら転記先Bookを開いた時に 実行時エラー1004 がでました。
デバッグで確認すると
x = Range(copyR).Count + 1
の所でした。
うまくいけばよかったのですが（泣）
変更した部分の所ですが
Case nameShFrom1
If Not Intersect(Target, Union(Sh.Range(copyR1), Sh.Range(copyR4))) Is Nothing Then flag(1) = "X"
↑
この状態だと "X" の中に (copyR1) と (copyR4) に代入された物が入っていると思っているのですが。。。。
間違ってますでしょうか？
（ちぃさん） 2015/01/24(土) 15:44
名前定義はできていますか？
（マナ） 2015/01/24(土) 16:06
確認しましたが名前の定義はできていると思います。
（マナ）さんに作って頂いたマクロでしてはいませんが手動で
セルを選択⇒名前の定義⇒名前(N)に範囲1と入力⇒OK
の手順で進めました。
名前の管理で確認しても設定した範囲と設定した名前で記録がありました。
もしかして。。。。何か勘違いしてますでしょうか。。。。私。。。。(汗)
ちなみに （マナ）さんに作って頂いたマクロで名前の定義をするときはコードに追加が必要でしょうか？
「変数が定義されていません」とでます。
これまた私の勘違いかもしれないのですが （マナ）さんに作って頂いたマクロは標準モジュールに書き写しましたが正しいでしょうか？
（ちぃさん） 2015/01/24(土) 17:52
＞「変数が定義されていません」とでます
現在のコードがある標準モジュールに名前定義のマクロをコピペしてもらうつもりでした。変数を共有しているので。 名前定義を手動でしているのであれば問題ありません。
今は、じっくりコードを読み解く、気力がないので、 見当違いかもあいれませんが、下記の変更でどうなるでしょうか。 エラーはでないと思います。
x = Range(copyR).Count + 1 'コピーセル数+1 ↓ x = .Count + 1 'コピーセル数+1
（マナ） 2015/01/24(土) 18:35
みにくいので、その都度、元スレのぶらっとさんのコードで確認していたのですが、
面倒になってきましたので、こっちのスレにコピペしたうえで、今回修正を反映させました。
修正箇所に★をつけてあります。
Option Explicit
Dim WithEvents xlapp As Application Dim flag() As String Dim wbOT As Workbook
Const nameOT As String = "他のBook.xlsx" Const nameShTo As String = "Sheet1"
Const copyR1 As String = "範囲1" '★変更 Const copyR2 As String = "範囲2" '★変更 Const copyR3 As String = "範囲3" '★変更 Const nameShFrom1 As String = "Sheet1" Const nameShFrom2 As String = "Sheet2" Const nameShFrom3 As String = "Sheet3"
Private Sub Workbook_Open()
Set xlapp = Application
On Error Resume Next 'まだ開かれていなかった場合の対応
Set wbOT = Workbooks(nameOT)
On Error GoTo 0
ReDim flag(1 To 3)
End Sub
Private Sub xlapp_WorkbookOpen(ByVal Wb As Workbook)
If Wb.Name = nameOT Then
Set wbOT = Wb
If wbOT.ActiveSheet.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_WorkbookActivate(ByVal Wb As Workbook)
If Wb.Name = nameOT Then
If Wb.ActiveSheet.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_SheetActivate(ByVal Sh As Object)
If Sh.Parent.Name = nameOT Then
If Sh.Name = nameShTo Then
If Len(Join(flag, "")) Then CopyLine
End If
End If
End Sub
Private Sub xlapp_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Parent Is ThisWorkbook Then
Select Case Sh.Name
Case nameShFrom1
If Not Intersect(Target, Sh.Range(copyR1)) Is Nothing Then flag(1) = "X"
Case nameShFrom2
If Not Intersect(Target, Sh.Range(copyR2)) Is Nothing Then flag(2) = "X"
Case nameShFrom3
If Not Intersect(Target, Sh.Range(copyR3)) Is Nothing Then flag(3) = "X"
End Select
End If
End Sub
Private Sub CopyLine()
Dim nameF As String
Dim copyR As String
Dim shF As Worksheet
Dim z As Long
Dim x As Long
Dim y As Long
Dim v() As Variant
Dim c As Range
Dim k As Long
Dim shT As Worksheet
Set shT = wbOT.Sheets(nameShTo)
For y = 1 To UBound(flag)
If Len(flag(y)) Then
'転移シートデータ最終行をA列で判断
z = shT.Range("A" & shT.Rows.Count).End(xlUp).Row + 1
nameF = VBA.Array(nameShFrom1, nameShFrom2, nameShFrom3)(y - 1)
copyR = VBA.Array(copyR1, copyR2, copyR3)(y - 1)
With Sheets(nameF).Range(copyR)
x = .Count + 1 '★変更
ReDim v(1 To x)
v(1) = Date
k = 1
For Each c In .Cells
k = k + 1
v(k) = c.Value
Next
shT.Range("A" & z).Resize(, x).Value = v
End With
End If
Next
ReDim flag(1 To UBound(flag))
End Sub
（マナ） 2015/01/24(土) 19:51
問題なく動作しました。
以前よりデーターを集める項目が増えて困っていたので凄く嬉しいです。
少し質問させてください。
1,名前の定義って上限はあるのですか？
2,今は手元にはないのですが2003でも拡張子を変更すればこのまま使えるのですか？
もし良ければ教えていただけないでしょうか。
宜しくお願いいたします。
（ちぃさん） 2015/01/24(土) 20:33
＞1,名前の定義って上限はあるのですか？
わかりません。逆に調べていただいてわかったら教えて下さい。
＞2,今は手元にはないのですが2003でも拡張子を変更すればこのまま使えるのですか？
2003でも問題なく動作すると思います。
名前定義のマクロ修正しました。 マクロブックからWorkbooks(nameOT)へ転記だったのですね。逆方向で考えていました。 ただし、このマクロ、アドレス入力するのが手間で意味なかったかも。
Sub 転記元に名前定義()
Const 転記元1 As String = "A1,B1,C1,D1,E1,F1,G1,H1,I1,J1"
Const 転記元2 As String = "A5,B5,C5,D5,E5,F5,G5,H5,I5,J5,K5"
Const 転記元3 As String = "A7"
With ThisWorkbook '★ここ修正
defName .Sheets(nameShFrom1), 転記元1, "範囲1"
defName .Sheets(nameShFrom2), 転記元2, "範囲2"
defName .Sheets(nameShFrom3), 転記元3, "範囲3"
End With
End Sub
Private Sub defName(ws As Worksheet, Adr As String, myN As String)
Dim v
Dim i As Long
Dim r As Range
v = Split(Adr, ",")
Set r = ws.Range(v(0))
For i = 1 To UBound(v)
Set r = Union(r, ws.Range(v(i)))
Next
r.Name = myN
End Sub
（マナ） 2015/01/24(土) 21:09
＞わかりません。逆に調べていただいてわかったら教えて下さい。
時間がある時にやってみます。w
＞ただし、このマクロ、アドレス入力するのが手間で意味なかったかも。
そんなことないです。
私は勉強になるのでありがたいです。(感謝)
色々とありがとうございます。
また躓きましたら質問にきたいとおもいます。
ありがとうございました。
（ちぃさん） 2015/01/24(土) 21:26
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.