Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

93 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【80609】Re:フォルダ内のファイルの一部シートの...

ｍｋｍｋ - 19/3/17(日) 20:33 -


	引用なし

	パスワード

すみません。

ご指摘の通り、記述に漏れがありました。
.End(xlToLeft)
無事、転記ができました。
ただ、貼り付けは行方向に追加したかったのですが、
列方向に貼り付く記述でした。
最初の記述に気が付きませんでした。

貼り付け元a1:b30 で、貼り付け先での2ファイル目からa30:b60
というように行方向に追加されるには

再度申し訳ございません。自身でも
Cells(Rows.Count, 1).End(xlUp)とOffset(30, 0)等行ってみたのですが、
上手くいきません
教えて頂けないでしょうか。

Sub sample()
　　Dim myPath As String
　　Dim myFile As String
　　Dim target As Range
　　On Error Resume Next
　
　　myPath = ThisWorkbook.Path & "\"
　　Application.Calculation = xlCalculationManual
　　Application.ScreenUpdating = False
　
　　 myFile = Dir(myPath & "*.xlsx")
　
　　 Do Until myFile = ""
　　
　　 If myFile <> ThisWorkbook.Name Then
　　 Set target = ThisWorkbook.Worksheets("全集計").Cells(1, Columns.Count).End(xlToLeft)
　　 With Workbooks.Open(Filename:=myPath & myFile)
　　.Worksheets("集計").Range("a1:b30").Copy target.Offset(0, 1)
　　.pastspecial Paste:=xlPasteValues
　　Application.CutCopyMode = False
　　.Close savechanges:=False
　　 End With
　　 End If
　　 myFile = Dir()
　 Loop
　
　　End Sub

・ツリー全体表示


	【80608】Re:フォルダ内のファイルの一部シートの...

マナ - 19/3/17(日) 17:26 -


	引用なし

	パスワード

▼ｍｋｍｋさん：

指摘箇所が、修正されていないのはなぜでしょうか？
ここまでの、やり取りを、再確認お願いします。

・ツリー全体表示


	【80607】Re:フォルダ内のファイルの一部シートの...

ｍｋｍｋ - 19/3/17(日) 17:18 -


	引用なし

	パスワード

何度もすみません・・。

Sub sample()
　　Dim myPath As String
　　Dim myFile As String
　　Dim target As Range
　　On Error Resume Next
　　
　　myPath = ThisWorkbook.Path & "\"
　　Application.Calculation = xlCalculationManual
　　Application.ScreenUpdating = False
　　
　　myFile = Dir(myPath & "*.xlsx")
　　
　　Do Until myFile = ""
　　
　　 If myFile <> ThisWorkbook.Name Then
　　
　　
　　Set target = ThisWorkbook.Worksheets("全集計").Cells(1, Columns.Count)
　　　
　　　
　　With Workbooks.Open(Filename:=myPath & myFile)
　　.Worksheets("集計").Range("a1:b30").Copy Destination:=target.Offset(0, 1)
　　.pastspecial Paste:=xlPasteValues
　　Application.CutCopyMode = False
　　.Close savechanges:=False
　　 End With
　　 End If
　　 myFile = Dir()
　 Loop
　
　 End Sub

▼マナさん：
>▼ｍｋｍｋさん：
>
>>ただ、やはり貼付先の集計FILE　SHEET全集計には貼りつきません。
>
>現在のコードを、もう一度、ここに貼り付けてください。

・ツリー全体表示


	【80606】Re:フォルダ内のファイルの一部シートの...

マナ - 19/3/17(日) 17:01 -


	引用なし

	パスワード

▼ｍｋｍｋさん：

>ただ、やはり貼付先の集計FILE　SHEET全集計には貼りつきません。

現在のコードを、もう一度、ここに貼り付けてください。

・ツリー全体表示


	【80605】Re:フォルダ内のファイルの一部シートの...

ｍｋｍｋ - 19/3/17(日) 16:47 -


	引用なし

	パスワード

▼マナさん：
そういう事だったのですね・・・検討違いな考えを・・すみません。

ただ、やはり貼付先の集計FILE　SHEET全集計には貼りつきません。
貼り付け元の方で、範囲を指定してＣｏｐｙまでは進んでいるようなのですが、
もしかすると、そのまま貼り付け元に貼り付けしているのかもしれません。

ほかに原因があるのでしょうか・・・。

>▼ｍｋｍｋさん：
>
>形式を選択して貼り付けは、１行ではかけません。

>
>.Worksheets("集計").Range("a1:b30").Copy
>target.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
>Application.CutCopyMode = False

・ツリー全体表示


	【80604】Re:フォルダ内のファイルの一部シートの...

マナ - 19/3/17(日) 16:33 -


	引用なし

	パスワード

▼ｍｋｍｋさん：

形式を選択して貼り付けは、１行ではかけません。

.Worksheets("集計").Range("a1:b30").Copy
target.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

・ツリー全体表示


	【80603】Re:フォルダ内のファイルの一部シートの...

ｍｋｍｋ - 19/3/17(日) 15:58 -


	引用なし

	パスワード

マナさん
URLもよく見ていたのですが・・・わからず・・すみません。
pastspecialの前に貼り付け先のオブジェクト（RANGE等)がないという事でしょうか？その場合貼り付け先の、FILE SHEET RANGを順に記述すればよいのでしょうか？
貼り付け先のオブジェクトをどのように記述してよいかわからず悩んでいます。

最初の段階でも貼り付け元のファイルは開くが、貼り付けられないでいるので、貼り付け先が正しく指定されていない事が要因だとは思うのですが・・・

With Workbooks.Open(Filename:=myPath & myFile)
　　.Worksheets("集計").Range("a1:b30").Copy Destination:=target.Offset(0, 1).pastspecial, Paste:=xlPasteValues
　　.Close savechanges:=False

>>Copy Destination:=target.Offset(0, 1).pastspecialの後に
>>　.pastspecial, Paste:=xlPasteValues
>>を追加したのですが、うまくいきませんでした。
>
>
>pastspecialの構文が間違っています。
>適当にしてもうまくいきません。
>まずは、ヘルプやネットで検索するようにしてください。
>
>ht tps://www.moug.net/tech/exvba/0050104.html

・ツリー全体表示


	【80602】Re:フォルダ内のファイルの一部シートの...

マナ - 19/3/17(日) 15:03 -


	引用なし

	パスワード

▼ｍｋｍｋさん：

>Copy Destination:=target.Offset(0, 1).pastspecialの後に
>　.pastspecial, Paste:=xlPasteValues
>を追加したのですが、うまくいきませんでした。

pastspecialの構文が間違っています。
適当にしてもうまくいきません。
まずは、ヘルプやネットで検索するようにしてください。

ht tps://www.moug.net/tech/exvba/0050104.html

・ツリー全体表示


	【80601】Re:フォルダ内のファイルの一部シートの...

ｍｋｍｋ - 19/3/17(日) 14:21 -


	引用なし

	パスワード

ご返答ありがとうございます。
再度お願いします。

Copy Destination:=target.Offset(0, 1).pastspecialの後に
　.pastspecial, Paste:=xlPasteValues
を追加したのですが、うまくいきませんでした。
データの貼り付け先が不明のようです。
低レベルで申し訳ありません・・・。

.Worksheets("集計").Range("a1:b30").Copy Destination:=target.Offset(0, 1)
>
>>【質問】→この行の下に下記の記述をもってくればよいという事でしょうか？
>> Cells.Select
>>　 Selection.Copy
>>　 Selection.pastspecial Paste:=xlpastvalues, operation:=xlNone, skipblanks_:=False, transpse:=False
>>　 Application.CutCopyMode = False
>
>
>いいえ。それだと、
>
>１）コピー→全てを貼付け、
>２）再度、コピー→値貼り付け
>
>となるので
>
>１）コピー→値貼り付け
>
>だけでは、だめですか。

・ツリー全体表示


	【80600】Re:フォルダ内のファイルの一部シートの...

マナ - 19/3/17(日) 13:55 -


	引用なし

	パスワード

▼ｍｋｍｋさん：

>【質問】→この行の下に下記の記述をもってくればよいという事でしょうか？
> Cells.Select
>　 Selection.Copy
>　 Selection.pastspecial Paste:=xlpastvalues, operation:=xlNone, skipblanks_:=False, transpse:=False
>　 Application.CutCopyMode = False

いいえ。それだと、

１）コピー→全てを貼付け、
２）再度、コピー→値貼り付け

となるので

１）コピー→値貼り付け

だけでは、だめですか。

・ツリー全体表示


	【80599】Re:フォルダ内のファイルの一部シートの...

ｍｋｍｋ - 19/3/17(日) 13:26 -


	引用なし

	パスワード

▼マナさん：
早速のお返事ありがとうございます。
何度もすみません。もう少し質問させてください。

Set target = ThisWorkbook.Worksheets("全集計").Cells.SpecialCells(xlCellTypeLastCell).Offset(0).End(xlToLeft)
>こうではないですか？
>Set target = ThisWorkbook.Worksheets("全集計").Cells(1, Columns.Count).End(xlToLeft)
target = myFile
>これは、意味不明です。削除したほうがよいのでは
　→上記2点をこのように変更しました。
>>　　.Worksheets("集計").Range("a1:b30").Copy Destination:=target.Offset(0, 1)
>この段階で、値のみ転記ではだめなのでしょうか？

【質問】→この行の下に下記の記述をもってくればよいという事でしょうか？
Cells.Select
　 Selection.Copy
　 Selection.pastspecial Paste:=xlpastvalues, operation:=xlNone, skipblanks_:=False, transpse:=False
　 Application.CutCopyMode = False

・ツリー全体表示


	【80598】Re:Sheet間の転記について

tarutaru - 19/3/17(日) 12:47 -


	引用なし

	パスワード

マナ様

オフセットの使用でできました!!

助かりました。また、勉強にもなりました。

今回も的確なアドバイスありがとうございます!!

今後もよろしくお願いいたします。

・ツリー全体表示


	【80597】Re:フォルダ内のファイルの一部シートの...

マナ - 19/3/17(日) 12:25 -


	引用なし

	パスワード

▼ｍｋｍｋさん：

>　　　　Set target = ThisWorkbook.Worksheets("全集計").Cells.SpecialCells(xlCellTypeLastCell).Offset(0).End(xlToLeft)

こうではないですか？

Set target = ThisWorkbook.Worksheets("全集計").Cells(1, Columns.Count).End(xlToLeft)

　　
>　　　　target = myFile

これは、意味不明です。削除したほうがよいのでは？

>　　

>　　.Worksheets("集計").Range("a1:b30").Copy Destination:=target.Offset(0, 1)

この段階で、値のみ転記ではだめなのでしょうか？

・ツリー全体表示


	【80596】Re:Sheet間の転記について

マナ - 19/3/17(日) 12:07 -


	引用なし

	パスワード

▼tarutaru さん：

不規則だけど、転記先は固定ならば、
一例ですが、こんな感じで

Sheets("Sheet2").Range("A1").Value = Target.Value
Sheets("Sheet2").Range("B1").Value = Target.Offset(, 1).Value

ダブルクリックしたセルが　Target　で、
Targetからの相対的な位置が決まっているなら、Offsetが使えます。

・ツリー全体表示


	【80595】フォルダ内のファイルの一部シートの集計

ｍｋｍｋ - 19/3/17(日) 12:00 -


	引用なし

	パスワード

ＶＢＡ初心者です。

同じフォルダ内の複数ファイルのSHEET"集計"のDATAを同じフォルダにある集計用ファイルのSHEET全集計にコピペしたいです。
集計元のファイルを順番に開いて、集計先の全集計の空白行に続けて転記していく記述をサイト検索し行ったのですが、集計元のファイルは開くのですが、集計先に貼り付けされないです。

11行目のSET TARGET＝にカーソルを当てると、本来は集計先であるはずの
内容が、集計元のファイルが表示されます。
ここが原因だと思うのですが、どのような記述にすればよいのかわからず
ご教授頂けないでしょうか。

何卒宜しくお願いいたします。

Sub sample()
　　Dim myPath As String
　　Dim myFile As String
　　Dim target As Range
　　On Error Resume Next
　　
　　myPath = ThisWorkbook.Path & "\"
　　Application.Calculation = xlCalculationManual
　　Application.ScreenUpdating = False
　　
　　myFile = Dir(myPath & "*.xlsx")
　　
　　Do Until myFile = ""
　　
　　 If myFile <> ThisWorkbook.Name Then
　　
　　
　　　　Set target = ThisWorkbook.Worksheets("全集計").Cells.SpecialCells(xlCellTypeLastCell).Offset(0).End(xlToLeft)
　　
　　　　target = myFile
　　
　　With Workbooks.Open(Filename:=myPath & myFile)
　　.Worksheets("集計").Range("a1:b30").Copy Destination:=target.Offset(0, 1)
　　.Close savechanges:=False
　　 End With
　　 End If
　　 myFile = Dir()
　 Loop
　
　 Cells.Select
　 Selection.Copy
　 Selection.pastspecial Paste:=xlpastvalues, operation:=xlNone, 　skipblanks_:=False, transpse:=False
　 Application.CutCopyMode = False

End Sub

・ツリー全体表示


	【80594】Re:Sheet間の転記について

tarutaru - 19/3/17(日) 11:12 -


	引用なし

	パスワード

マナ様

早速のご返信ありがとうございます。
今回もお手数をおかけしますが、よろしくお願いいたします。

ご指摘の部分ですが、

Sheet1のB3から、B128(余裕を持って128にしています）まで、「建物名」が入力されています。その「建物名」セルをダブル・クリックするとSheet2（ A1）に移動する構文は次のように書いています。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range,Cancel As Boolean)

If Intersect(Target,Range(B3:B128)) Is Nothing Then Exit Sub
Application.Goto sheets(2).Range(“A1”)
　Cancel = True

End Sub

例として、Sheet1のC3 には、「所在地」を、D3には「所有者」を、E3には「連絡先」を、F3には「建築年月日」を、G3には「構造」を入力するようにしてあります。※入力はフォームまたは、セルに直入力。

それを、Sheet2のセルに（以下のように）ダブル・クリックでSheet1からSheet2に移動するとともに、転記完了となるようにしたいのです。

Sheet1　　　　　　　　　Sheet2
　B3　　　　　→　　　　A1　　　
　C3　　　　　→　　　　B1
　D3　　　　　→　　　　A2
　E3　　　　　→　　　　B2
　F3　　　　　→　　　　C1
　G3　　　　　 →　　　　 D1
　H3　　　　　 →　　　　 C2

マナ様、お忙しい中、申し訳ありませんが、よろしくお願いいたします。

・ツリー全体表示


	【80593】Re:Sheet間の転記について

マナ - 19/3/16(土) 20:18 -


	引用なし

	パスワード

▼tarutaru さん：

>Sheet1のRange(B3)に用意している「建物名」セルをダブル・クリックすると、Sheet2の「印刷用の表」に移動出来るようにしているのですが、

そのコードを提示お願いします。
>
>質問は、「建物名」セルをダブル・クリックした際に、Sheet2に移動するとともに、その行のデータが不規則に並んでいる「印刷用の表」セルに転記出来るようにしたい。

具体例を挙げて、どのセルを、どこに転記したいのか説明お願いします。

・ツリー全体表示


	【80592】Sheet間の転記について

tarutaru - 19/3/16(土) 18:21 -


	引用なし

	パスワード

またお世話になります。

Sheet1に「データ表」があり、Sheet2に「印刷用の表」を用意しています。
Sheet1の「データ表」はRange(B3:N3)の範囲で、100行ほどあり、「印刷用の表」にはA4用紙に縦印刷を考えているため、Sheet1「データ表」のセル・データを格納するセルが不規則に並んでいます。

Sheet1のRange(B3)に用意している「建物名」セルをダブル・クリックすると、Sheet2の「印刷用の表」に移動出来るようにしているのですが、

質問は、「建物名」セルをダブル・クリックした際に、Sheet2に移動するとともに、その行のデータが不規則に並んでいる「印刷用の表」セルに転記出来るようにしたい。
というものです。

どなたかお詳しい方、御教示お願いいたします。

・ツリー全体表示


	【80591】Re:Worksheet.Delete の動き

マナ - 19/3/15(金) 18:54 -


	引用なし

	パスワード

▼北浦さん：

ontimeメソッドを使って、
シート削除後に、インポートではだめですか？

・ツリー全体表示


	【80590】Re:型が一致しないがわかりません

マナ - 19/3/15(金) 18:37 -


	引用なし

	パスワード

▼ゆうすけさん：

>Sh2Range.Offset(newRecordOffset, 0).Value = newRecordValues
>で、「型が一致しない」となってしまいます。

たぶん、それより前の段階で間違っていると思います。

>Dim newRecordOffset As Variant
>Set newRecordOffset = Sh2.Range("E24")

Option Explicit

Sub saveData()
　　Dim i As Long
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim Sh1Range As Range
　　Dim Sh2Range As Range
　　Dim newRecordOffset As Long
　　Dim dataRow As Long
　　
　　Set Sh1 = Worksheets("1")
　　Set Sh1Range = Sh1.Range("K14:K41")
　　Set Sh2 = Worksheets("2")
　　Set Sh2Range = Sh2.Range("E24")

　　For i = 14 To 41
　　　　If Worksheets("1").Cells(i, 16).Value = 1 Then
　　　　　　dataRow = 1
　　　　　　newRecordOffset = Sh2Range.Value
　　　　　　
　　　　　　Do While Sh1Range.Cells(dataRow, 0).Value <> ""
　　　　　　　　Sh2Range.Offset(newRecordOffset, 0).Value = _
　　　　　　　　　　　　Sh1Range.Cells(dataRow, 1).Value
　　　　　　　　dataRow = dataRow + 1
　　　　　　　　newRecordOffset = newRecordOffset + 1
　　　　　　Loop
　　　　　　
　　　　End If
　　Next i
　　
End Sub

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

93 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free