Excel VBA質問箱 IV

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

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


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

250 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【77439】Re:あるセルに手入力したら、その下のセ...

β - 15/10/2(金) 17:28 -


	引用なし

	パスワード

▼kouka さん：

同姓同名というのは　変数　にお名前のことです。
それはさておき、要件を誤解しているかもしれませんが

Private Sub Worksheet_Change(ByVal Target As Range)
　　'A1変更があった時のみ処理
　　If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
　　'今回はマクロ内での変更はA2なのでなくてもいいけどたしなみとして
　　Application.EnableEvents = False　　'イベント発生抑止
　　Range("A2").ClearContents
　　Application.EnableEvents = True　　 'イベント発生再開
End Sub

・ツリー全体表示


	【77438】Re:あるセルに手入力したら、その下のセ...

Jaka - 15/10/2(金) 17:07 -


	引用なし

	パスワード

>Range("A2").ClearContents
これでセルの内容を変更しているので、また
Worksheet_Change　イベントが発生します。
で、またクリアすると、Worksheet_Change　イベントが発生します。
で、なんかしらが溜まり積もって、スタックオーバー・・。
こんな感じに書き込む前にイベントを中止しましょう。

Application.EnableEvents = False 'イベント中止
Range("A2").ClearContents
Application.EnableEvents = True　'書き終わったら戻す。

・ツリー全体表示


	【77437】Re:あるセルに手入力したら、その下のセ...

kouka - 15/10/2(金) 16:43 -


	引用なし

	パスワード

βさん、ヒントありがとうございました!
・・・ですが、また壁に当たってしまったので、質問させてください。

worksheetに下記のコードを作ったのですが・・・

Private Sub Worksheet_Change(ByVal Target As Range)

　　Dim 商品名 As String

　　If Range("$A$1") <> 商品名 Then
　　　　Range("A2").ClearContents
　　　　商品名 = Range("$A$1")
　　End If

End Sub

『実行時エラー'28':スタック領域が不足しています。』と出てきて、
Excel自体が再起動してしまいます。

ちなみに前回書き忘れましたが、Win7のExcel2010です。

それと同姓同名の場合でも同じ処理をしたいので、
それは考えなくていいです。

こんな短いコードでこんなにうまくいかないのは久しぶりで、
どうしたらいいのか、わけわからん状態ですが、
すみませんが、教えてください。。。
よろしくお願いします。

・ツリー全体表示


	【77436】Re:繰り返し　コピーペースト

YUKI - 15/10/2(金) 16:10 -


	引用なし

	パスワード

▼β さま

完璧です！！思い通りの結果になりました！
容量も激減し速度も速い・・さすがです。

教えていただいたコードを少しづつ理解し、
いつか解答できる立場になれたらなぁと思います。
本当にありがとうございました！！

・ツリー全体表示


	【77435】Re:繰り返し　コピーペースト

β - 15/10/2(金) 15:07 -


	引用なし

	パスワード

▼YUKI さん：

要件の誤解あれば指摘ください。

Sub Test2()
　　Dim myA As Range
　　Dim myC As Range
　　Dim r As Range
　　Dim col As Range
　　Dim pos As Range
　
　　Application.ScreenUpdating = False
　　
　　Set myA = Range("AG1:BL180")　　'列数が増減あればここを変更
　　Set r = Range("E4:S180")　　　　'関数で生成される領域
　　
　　For Each myC In myA.Columns　　'mya から　列単位で変数 myc に取出し
　　　　Range("A1").Resize(myA.Rows.Count).Value = myC.Value
　　　　myC.EntireColumn.ClearContents
　　　　Set pos = Nothing
　　　　For Each col In r.Columns
　　　　　　If pos Is Nothing Then
　　　　　　　　Set pos = myC.Cells(1)
　　　　　　End If
　　　　　　pos.Resize(r.Rows.Count).Value = col.Value
　　　　　　Set pos = pos.Offset(r.Rows.Count)
　　　　Next
　　　　myC.Resize(Cells(Rows.Count, myC.Column).End(xlUp).Row).Sort Key1:=myC.Cells(1), Header:=xlYes
　　Next
　　
End Sub

・ツリー全体表示


	【77434】Re:繰り返し　コピーペースト

YUKI - 15/10/2(金) 8:14 -


	引用なし

	パスワード

▼β 様：
頂いたコードは希望どうりに動いております。ありがとうございます。
言葉足らずで申し訳ありません。。

説明が下手で重ね重ね申し訳ありません。

・A列へ1列コピー
・A列へ貼り付けたデータをE4:S180で関数を使って加工
・E4:S180のデータをAE列を使ってソート
・最初にA列へコピーした列と置き換え
それをAG列からBL列まで順に処理

現状は前回書いたコードを単純に必要列分表記してとても長いコードになっています。

・ツリー全体表示


	【77433】Re:VBAで別ブックから反映について

β - 15/10/2(金) 0:17 -


	引用なし

	パスワード

▼馬さん：

ブックの構成が不明ですが、
ブックA.xlsx と　ブックB.xlsx があり、それとは別にマクロブックがあるというコードです。
実行時には、ブックAもブックBも、あらかじめ開かれているということが前提。
もちろん、マクロ内で、この２つのブックを自動的に開いて処理することもできますが、
まずは、あらかじめ、ひらかれているということで。

マクロブックの標準モジュールに。
★印のところは、実際のものに直してください。

Sub Test()
　　Dim shA As Worksheet
　　Dim shB As Worksheet
　　
　　Set shA = Workbooks("ブックA.xlsx").Sheets("Sheet1")　　'★
　　Set shB = Workbooks("ブックB.xlsx").Sheets("Sheet1")　　'★
　　
　　With shB.Range("A2", shB.Range("A" & Rows.Count).End(xlUp)).Offset(, 5)
　　　　.Formula = "=IFERROR(VLOOKUP(A2," & shA.Range("A1").CurrentRegion.Address(External:=True) & ",3,FALSE),"""")"
　　　　.Value = .Value
　　End With
　　
End Sub

・ツリー全体表示


	【77432】VBAで別ブックから反映について

馬 - 15/10/1(木) 23:03 -


	引用なし

	パスワード

教えてください！

別ブックにある内容をVBAを使用し、
反映したいのですが方法が分かりません。

具体的には、
ブックAの
A列に"商品コード"、
B列に"商品名"、
C列に"備考"があります。
そしてブックBには、
A列に"商品コード"、
B列に"商品名"、
F列に"備考"、
があるので、
ブックAの商品コードにある備考(C列)を、
ブックBから同じ商品コードを探して、そのF列に反映
していきたいのですが上手くいきません。

※ブックAはブックBを元に作成してるので、
必ず合致するコードはあります。

どなたかお助け下さい！！

・ツリー全体表示


	【77431】Re:繰り返し　コピーペースト

β - 15/10/1(木) 17:13 -


	引用なし

	パスワード

▼YUKI さん：

要件を読んでみましたが、どうも、よくわかりません。
なので、【動くことは動いている】という、そちらのコードを読んで
要件を推測しようとしているのですが、なかなかわかりません。

そちらのコードは

・E4:S180 の領域の各列を順番に、AE4 から列単位に転記して
・出来上がった AE列を並び替えて
・それを AG1:AG180 に転記して

・また、E4:S180 の領域(つまり、↑で対象にしたのと同じデータ）の各列を順番に、AE4 から列単位に転記して
・出来上がった AE列を並び替えて
・それを AH1:AH180　に転記

この繰り返しだと思いますが、

>AG～BL（増減の可能性あり）の1～180行のデータを

この AG～BLといったものがコードに登場しないのですが？？

また、コードの中で、各ブロックごとに

Range("AG1:AG180").Copy Range("A1:A180")

等としていますが、コピー先の A1:A180 は、まったく参照されていません。
何をしたかったのかなぁ・・と。

具体的には何をどうしたいのですか？

・ツリー全体表示


	【77430】Re:繰り返し　コピーペースト

β - 15/10/1(木) 16:33 -


	引用なし

	パスワード

▼YUKI さん：

>少し状況が変わりまして、

新しい要件は今から読んで、対応しますが、それとは別に
以前の要件通りのデータで、アップしたマクロを動かした結果はどうでしたか？
それがうまくいったかどうかの連絡をください。

（要件を変えるから、動かしてもしょうがないので動かしていない　ということはないですよね）

・ツリー全体表示


	【77429】Re:繰り返し　コピーペースト

YUKI - 15/10/1(木) 14:12 -


	引用なし

	パスワード

返信遅くなりまして申し訳ありません。

少し状況が変わりまして、
AEに纏めるデータはE4:S180へ（修正しました。）
AG～BL（増減の可能性あり）の1～180行のデータを
A1：180へ貼ってまとめ、元の列へ上書きとしたいです。
AE列を経由しなくても構いません
以下のコードを書きましたが、
繰り返しが上手くできず全列分このコードをVBAに書く事しかできませんでした。
現状動いてはいるのですが列の増減での修正が手間でしょうがありません。。。
よろしくお願いします

　　Dim r As Range
　　Dim col As Range
　　Dim pos As Range
　
　　Application.ScreenUpdating = False
'######AG
　　Range("AE2:AE5000").Clear
　　Range("AG1:AG180").Copy Range("A1:A180")
　
　　Set r = Range("E4:S180")
　
　　For Each col In r.Columns
　　　　If pos Is Nothing Then
　　　　　　Set pos = Range("AE4")
　　　　End If
　　　　pos.Resize(r.Rows.Count).Value = col.Value
　　　　Set pos = pos.Offset(r.Rows.Count)
　　Next

　 Range("AE1:AE5000").Sort _
　　　　Key1:=Range("AE1"), _
　　　　Order1:=xlAscending, _
　　　　Header:=xlYes, _
　　　　Orientation:=xlTopToBottom
　
　 Range("AG1:AG180").Value = Range("AE1:AE180").Value
'######AH
　　Range("AE2:AE5000").Clear
　　Range("AH1:AH180").Copy Range("A1:A180")
　
　　Set r = Range("E4:S180")
　
　　For Each col In r.Columns
　　　　If pos Is Nothing Then
　　　　　　Set pos = Range("AE4")
　　　　End If
　　　　pos.Resize(r.Rows.Count).Value = col.Value
　　　　Set pos = pos.Offset(r.Rows.Count)
　　Next

　 Range("AE1:AE5000").Sort _
　　　　Key1:=Range("AE1"), _
　　　　Order1:=xlAscending, _
　　　　Header:=xlYes, _
　　　　Orientation:=xlTopToBottom
　
　 Range("AH1:AH180").Value = Range("AE1:AE180").Value

・ツリー全体表示


	【77428】Re:あるセルに手入力したら、その下のセ...

β - 15/9/30(水) 20:52 -


	引用なし

	パスワード

▼kouka さん：

ループしているというのは勘違いじゃないですか？
ループはしていないと思いますよ。ただ、思ったような結果にならないだけでは？

う～ん・・・
コードとしては（これだけ短いこーどなのに）間違い部分が満載です。

まず、SelectionChageイベントは適切ではありません。
Changeイベントを使うべきですね。

次に、通常、イベント処理においては、動きのあったセルが、マクロで対象としているかどうかのチェックをします。
（対象外のせるなら無視）
それをしていませんね。

そもそもが、Changeイベント　と　標準モジュールにわけて処理することが、めずらしいですね。
もちろん、それが妥当かつ必要なら、わけることもありますけど、今回は全く不要ですね。

最大の間違いは、この Macro1 には商品名という変数定義はありません。
モジュールの先頭に Option Explicit の記述がないと思われますが、それがないので
たまたまコンパイルエラーにはなりませんが、ここでの宣言のない変数は、テンポラリーに
生成されます。同姓同名ですけど、SelectionChangeイベントの商品名という名前の変数とは、まったく別物。
なので、これが実行されたとしても、SelectionChangeイベントでは　やはり <> です。

まずはイベントを適切なもの（Changeイベント)にした上で、対象のセル（A1)の変更かｄ峰かを判定するのが第一歩。
次に同姓同名だけど別の変数というところをどうするか、これが第二歩。
これについては、Changeイベント内で、完結させれば解決します。

がんばってください。
壁にぶつかればＳＯＳをどうぞ。

・ツリー全体表示


	【77427】あるセルに手入力したら、その下のセルの...

kouka - 15/9/30(水) 18:31 -


	引用なし

	パスワード

いろいろ試行錯誤してみたのですが、
どうにも解決策が浮かばないので、
質問させていただきます。

例えば、A1セルとA2セルが入力欄で、
A1セルを手入力した場合、A2セルの中身をクリアしたいのですが、
うまくいかないのです。

｜A
――――
1｜りんご
――――
2｜300円

↓

｜A
――――
1｜みかん←A1に入力したら
――――
2｜　　　←A2がクリアにしたい

・worksheetに下記のコード

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　　Dim 商品名 As String

　　If Range("$A$1") <> 商品名 Then Call Macro1
End Sub

・標準モジュールに下記のコード

Sub Macro1()
　　Range("A2").ClearContents
　　商品名 = Range("$A$1")
End Sub

このままだとループしてるっぽいのですが、
どうしたら良いでしょうか??
すみませんが教えてくださいm(_ _)m
よろしくお願いします。

・ツリー全体表示


	【77426】Re:オートフィルタ　繰り返し

はる - 15/9/30(水) 16:25 -


	引用なし

	パスワード

すいません。自己解決しました

.Range("E3").CurrentRegion.Sort Key1:=Range("G3"), Order1:=xlDescending
悪さしてたのはSort　後の()でした。

お騒がせしました。また行き詰ったらお願いいたします。

・ツリー全体表示


	【77425】Re:オートフィルタ　繰り返し

はる - 15/9/30(水) 15:22 -


	引用なし

	パスワード

お礼を返したところに重ねて質問で申し訳ありません。

E3～H*に貼り付けたデータをG列で降順にソートした後
各貼り付けへ移行したいです。
（＊頂いた下記データにソートを追加したい）
.Range("E:H").PasteSpecial Paste:=xlPasteValues
の下に

.Range("E3").CurrentRegion.Sort(KEY1:=RANGE("G3"),Order1:=xlDescending)

と入力してみましたが
コンパイルエラー：　修正候補:=
で行き詰ってしまいました。
CurrentRegionでは認識しないのでしょうか･･･

>Sub test()
>　　Dim aSh As Worksheet
>　　Dim i　 As Integer
>　　
>　　Set aSh = Sheets("マクロセット")
>　　'#データ更新
>　　With aSh
>　　　　.Columns("E:J").Clear
>　　　　Sheets("計画").Range("K:N").Copy
>　　　　.Range("E:H").PasteSpecial Paste:=xlPasteValues
>　　　　Sheets("Data Base").Range("AP4:AP100").Copy
>　　　　.Range("J8").PasteSpecial Paste:=xlPasteValues
>　　　　
>　　　　.Range("E3:H3").AutoFilter
>
>　　　　If ActiveWorkbook.Worksheets.Count < 8 Then Exit Sub
>　　　　For i = 8 To ActiveWorkbook.Worksheets.Count
>　　　　　　.Range("$E$3:$H$5000").AutoFilter _
>　　　　　　　　Field:=4, Criteria1:=.Cells(i, 10).Value
>　　　　　　.Range("E3").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
>　　　　　　Sheets(i).Range("B53").PasteSpecial Paste:=xlPasteValues
>　　　　Next i
>　　End With
>　　
>End Sub

・ツリー全体表示


	【77424】Re:あるファイルの中身をシートごとにわ...

カイト - 15/9/29(火) 20:00 -


	引用なし

	パスワード

こんにちは。
返信が遅くなり、申し訳ありません。
アクティブシートにしたら、問題なく動作しました。
お手数をおかけして申し訳ありませんでした。
ありがとうございました。

▼ウッシさん：
>こんにちは
>
>マクロの設定されたブックに、シート名
>Sheet1～Sheet7
>の7シートは存在しているのですよね？
>
>実際にテストしたコードはどうなっていますか？

・ツリー全体表示


	【77423】Re:あるファイルの中身をシートごとにわ...

ウッシ - 15/9/29(火) 12:30 -


	引用なし

	パスワード

こんにちは

マクロの設定されたブックに、シート名
Sheet1～Sheet7
の7シートは存在しているのですよね？

実際にテストしたコードはどうなっていますか？

・ツリー全体表示


	【77422】Re:あるファイルの中身をシートごとにわ...

カイト - 15/9/29(火) 12:20 -


	引用なし

	パスワード

ありがとうございます。

t.Worksheets("Sheet" & j).Range("A5").EntireRow.Resize(Rows.Count - 5).ClearContents

こちらで、アプリケーションまたはオブジェクト定義エラーがでてしまいます。
マクロの内容は入力されたファイルが新しいエクセルファイルのシートに出力され、それがマクロを実行したエクセルにシートごとに分割して出力される作りになっているのですよね？
頭にwithをつけても駄目でした。
なぜ、マクロ実行エクセルが参照できないのでしょうか？

▼ウッシさん：
>こんにちは
>
>こんな感じでしょうか？
>
>Sub test()
>　　Dim f As Variant
>　　Dim b As Workbook
>　　Dim t As Workbook
>　　Dim i As Long
>　　Dim j As Long
>　　Dim a As Areas
>　　
>　　f = Application.GetOpenFilename("読み込みファイル (*.*), *.*", , , , False)
>　　If f = False Then Exit Sub
>　　
>　　Workbooks.OpenText Filename:= _
>　　　　f, Origin:=932, _
>　　　　StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
>　　　　ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
>　　　　Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array( _
>　　　　3, 1)), TrailingMinusNumbers:=True
>　　　　
>　　Set b = ActiveWorkbook
>　　Set t = ThisWorkbook
>　　Set a = b.Worksheets(1).UsedRange.SpecialCells(xlCellTypeConstants).Areas
>　　
>　　j = 1
>　　For i = 1 To a.Count
>　　　　If a(i).Cells(1, 1) Like "No*" Then
>　　　　　　If j < 7 Then
>　　　　　　　　t.Worksheets("Sheet" & j).Range("A5").EntireRow.Resize(Rows.Count - 5).ClearContents
>　　　　　　　　a(i).Offset(1).Copy t.Worksheets("Sheet" & j).Range("A5")
>　　　　　　　　j = j + 1
>　　　　　　ElseIf j = 7 Then
>　　　　　　　　a(i).Offset(1).Copy t.Worksheets("Sheet" & j).Range("A" & Rows.Count).End(xlUp).Offset(1)
>　　　　　　　　j = j + 1
>　　　　　　Else
>　　　　　　　　Exit For
>　　　　　　End If
>　　　　End If
>　　Next
>　　
>　　b.Close False
>　　
>End Sub

・ツリー全体表示


	【77421】Re:あるファイルの中身をシートごとにわ...

ウッシ - 15/9/29(火) 9:05 -


	引用なし

	パスワード

こんにちは

こんな感じでしょうか？

Sub test()
　　Dim f As Variant
　　Dim b As Workbook
　　Dim t As Workbook
　　Dim i As Long
　　Dim j As Long
　　Dim a As Areas
　　
　　f = Application.GetOpenFilename("読み込みファイル (*.*), *.*", , , , False)
　　If f = False Then Exit Sub
　　
　　Workbooks.OpenText Filename:= _
　　　　f, Origin:=932, _
　　　　StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
　　　　ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
　　　　Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array( _
　　　　3, 1)), TrailingMinusNumbers:=True
　　　　
　　Set b = ActiveWorkbook
　　Set t = ThisWorkbook
　　Set a = b.Worksheets(1).UsedRange.SpecialCells(xlCellTypeConstants).Areas
　　
　　j = 1
　　For i = 1 To a.Count
　　　　If a(i).Cells(1, 1) Like "No*" Then
　　　　　　If j < 7 Then
　　　　　　　　t.Worksheets("Sheet" & j).Range("A5").EntireRow.Resize(Rows.Count - 5).ClearContents
　　　　　　　　a(i).Offset(1).Copy t.Worksheets("Sheet" & j).Range("A5")
　　　　　　　　j = j + 1
　　　　　　ElseIf j = 7 Then
　　　　　　　　a(i).Offset(1).Copy t.Worksheets("Sheet" & j).Range("A" & Rows.Count).End(xlUp).Offset(1)
　　　　　　　　j = j + 1
　　　　　　Else
　　　　　　　　Exit For
　　　　　　End If
　　　　End If
　　Next
　　
　　b.Close False
　　
End Sub

・ツリー全体表示


	【77420】Re:あるファイルの中身をシートごとにわ...

カイト - 15/9/29(火) 8:41 -


	引用なし

	パスワード

こんにちは。
説明がわかりにくく、申し訳ありません。
拡張子が日付時間のタイムスタンプになっています。
例 aaabbb.201509280835

NoA,NoB,Count1の転記は必要ありません。
次の行の数字の組み合わせから改行までの数字の組み合わせをシートごとに記載したいです。

▼ウッシさん：
>こんにちは
>
>ファイル名:aaabbb.timestamp
>
>はどんなファイルですか？
>
>拡張子が「timestamp」のテキストファイルですか？
>
>NoA,NoB,Count1という部分も転記するのですか？
>
>
>▼カイトさん：
>>あるファイルの中身をシートごとにわけて入力するということを行いたいです。
>>シートごとに分けて入力する方法がわかりません。
>>,がある場合は区切って一セルごとに表示します。
>>
>>ファイル名:aaabbb.timestamp
>>
>>--------------ファイルの中身--------------
>>はじまり
>>
>>NoA,NoB,Count1
>>1010,1,360
>>432,3,254
>>・
>>・
>>2356,6,227
>>
>>
>>NoC,NoD,NoE,Count2
>>101,34,31,565
>>3432,33,5,254
>>・
>>・
>>564,4,5,462
>>
>>Next 3
>>
>>
>>NoAS,NoDS,NoFD,Count3
>>45,8,13,454
>>65,7,6,454
>>・
>>・
>>75,3,2,576
>>・
>>・
>>
>>
>>おわり
>>--------------ファイルの中身--------------
>>
>>このような形式のデータを
>>sheet1～7までに分けて入れたいです。
>>sheetは用意してあります、データが入っています。
>>sheet1～6はA5から最後までのデータを削除後、A5からデータを入れたいです。
>>sheet7は既に入っている最後のデータ行の次の行からデータを入れたいです。
>>
>>sheet1はNoA,NoB,Count1の次の行から改行まで
>>sheet2はNoC,NoD,NoE,Count2の次の行から改行まで
>>
>>Next 3（たまにこういういらない表記が途中にあります。はじまりとおわりもファイル内に書いてありますが、いらない表記です。）
>>
>>NoAS,NoDS,NoFD,Count3の次の行から改行まで
>>以降も似たような形式で書かれています。
>>一行の項目数は3または4となります。
>>
>>以上ですが、どなたかよろしくお願いいたします。

・ツリー全体表示


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

250 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free