Excel VBA質問箱 IV

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

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


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

286 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【76712】Re:マクロを実行するボタンの自動生成＆...

β - 15/3/3(火) 14:19 -


	引用なし

	パスワード

▼さとちぃさん：

>以下の様な形で試行錯誤中ですが、うまくいきません・・・・。

うまくいかないとは
・A1:A4の範囲でダブルクリックしているのに全く反応がない（メッセージが出ない）
・そのほかの不具合
具体的には、どういう状況でしょうか？

で、コードですが

・このコードは標準モジュールではなくシートモジュールに書きますが
　それはＯＫですか？
　シートモジュールのだしかたはいろいろあありますが、簡単なのは
　シートのシートタブを右クリックして、コードの表示を選ぶとでてきます。

・コードではA1:A4の範囲のダブルクリックをチェックしてますが、メッセージでは
A1:A10 となっています。ちょっとしたタイプミスだと思いますが。

・ダブルクリックの場合、TargetはActiveCellの単一セルですから
　Application.Intersect(ActiveCell, Range("A2:A4"))
　これで、全く問題はないのですが
　Application.Intersect(Target, Range("A2:A4"))
　こう書くほうが一般的かもしれません。

・ツリー全体表示


	【76711】Re:マクロを実行するボタンの自動生成＆...

独覚 - 15/3/3(火) 14:18 -


	引用なし

	パスワード

　▼さとちぃさん：

メッセージでは「セル範囲A1:A10内」となっているけれどもVBAでは
Set MyTarget = Application.Intersect(ActiveCell, Range("A2:A4"))
となっていることかな？

ただ、「ActiveCell」ではなくて「Target」でも構わないかと。

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

　　If Intersect(Target, Range("A1:A10")) Is Nothing Then Exit Sub
　　MsgBox "セル範囲A1:A10内のセルがダブルクリックされました"
　　Cancel = True
　　
End Sub

・ツリー全体表示


	【76710】Re:マクロを実行するボタンの自動生成＆...

さとちぃ - 15/3/3(火) 13:42 -


	引用なし

	パスワード

β様

さとちぃです。
早速ありがとうございます。

ダブルクリックによるマクロ実行は、私の勉強不足で知りませんでした。

以下の様な形で試行錯誤中ですが、うまくいきません・・・・。
おかしな点をご指摘いただけますでしょうか？

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

　　Set MyTarget = Application.Intersect(ActiveCell, Range("A2:A4"))
　　
　　If Not MyTarget Is Nothing Then
　　　　MsgBox "セル範囲A1:A10内のセルがダブルクリックされました"
　　　　Cancel = True
　　End If
End Sub

・ツリー全体表示


	【76709】Re:マクロを実行するボタンの自動生成＆...

β - 15/3/3(火) 10:46 -


	引用なし

	パスワード

▼さとちぃさん：

おはようございます。
回答ではないんですが、このテーマの一連のトピを拝見して
なぜボタン？　と思います。

たとえば、会社名のセル（A1とかC1とか）をダブルクリックしたら
当該の会社用の処理を実行するという構えにしておけば、会社が増えても
ボタンを追加してマクロ登録する必要もなくなるんですけど？

仮に会社が５００あれば、シート上に５００個のボタンがあるわけですね。
重いシートになりそうですが？

・ツリー全体表示


	【76708】マクロを実行するボタンの自動生成＆会社...

さとちぃ - 15/3/3(火) 9:32 -


	引用なし

	パスワード

いつもお世話になっております。
下記の件について、やり方がわからず教えていただけますでしょうか？

（やりたいこと）
緊急連絡網でそれぞれの会社名のセルの横に、検索用のための
マクロを走らせるボタン付けたいです。

単純にボタンを用意してマクロに関連付けることは出来ますが
会社が多すぎて、この作業をVBAにて自動化したいと考えてます。

　　　　A　　　　　　B　　　　　　　　C　　　　　　　D

1　株式会社ABC　　リンクボタン　　株式会社DFG　　リンクボタン
2
3　株式会社XYZ　　リンクボタン　　株式会社MOMOZ　　リンクボタン
4

　表には規則性があり、A、Cに必ず会社名が入り、その横のセルがリンクボタン用の
　セルとなります。　

　
（プログラムのコード）
　　
　　Sub 拠点情報ボタン自動生成
　　
　　もし、A列に文字列が入力されているならば、B列にオフセットしたセルにリンクボタンを生成しなさい。

　　もし、C列に文字列が入力されているならば、D列にオフセットしたセルにリンクボタンを生成しなさい。

　　ActiveSheet.Buttons.Add(以上のIF文で選択したセル).Select
　　Selection.OnAction = "拠点情報検索"
　　Selection.ShapeRange.ScaleWidth 14, msoFalse, msoScaleFromTopLeft
　　Selection.ShapeRange.ScaleHeight 7, msoFalse, msoScaleFromTopLeft
　　ActiveSheet.Shapes("Button 1635").Select
　　Selection.Characters.Text = "拠点情報"
　　With Selection.Characters(Start:=1, Length:=4).Font
　　　　.Name = "ＭＳＰゴシック"
　　　　.FontStyle = "標準"
　　　　.Size = 11
　　　　.Strikethrough = False
　　　　.Superscript = False
　　　　.Subscript = False
　　　　.OutlineFont = False
　　　　.Shadow = False
　　　　.Underline = xlUnderlineStyleNone
　　　　.ColorIndex = 1
　　End With

　こんな形で考えてますが、条件文、ボタン自動生成について教えていただけますでしょうか？
　

・ツリー全体表示


	【76707】Re:Excel2010 データインポートの際デー...

［名前なし］りえ - 15/3/2(月) 12:34 -


	引用なし

	パスワード

β様

ありがとうございました
▼β さん：
>▼りえさん：
>
>ご希望なので。
>先にコメントしたところも含めて、コードは、すべて元のままにしてあります。
>気になるところも多々ありますが・・・・・・
>Sheet1 は必ず処理されるんだということですから、Sheet2　の部分だけを以下。
>
>　　'sheet2
>　　Dim ws3 As Worksheet, ws4 As Worksheet
>　　Dim r1 As Range
>　　Dim n1 As Long
>　　Dim i1 As Long, j1 As Long, k1 As Long
>　　Dim done As Boolean　　　　 '★
>　　
>　　Set ws3 = Workbooks("C.xls").Worksheets("Sheet2")
>　　Set ws4 = Workbooks("B.xls").Worksheets("Sheet2")
>　　Set r1 = ws4.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
>　　
>　　If Not r1 Is Nothing Then　 '★
>　　
>　　　　n1 = Int((r1.Row - 2) / 20)
>　　　　
>　　　　If n1 >= 0 Then　　　　 '★
>　　　　　　
>　　　　　　done = True　　　　 '★
>　　　　　　
>　　　　　　Application.ScreenUpdating = False
>　　　　　　For i1 = 0 To n1
>　　　　　　　　If i1 > 0 Then ws3.Range("A1:J33").Copy ws3.Cells(33 * i1 + 1, 1)
>　　　　　　　　For j1 = 1 To 9
>　　　　　　　　　　If j1 = 1 Then k1 = j1 Else k1 = j1 + 1
>　　　　　　　　　　ws3.Cells(33 * i1 + 12, k1).Resize(20).Value = _
>　　　　　　　　　　ws4.Cells(20 * i1 + 2, j1).Resize(20).Value
>　　　　　　　　Next
>　　　　　　Next
>　　　　　　
>　　　　　　Dim x1 As Long
>　　　　　　For x1 = 1 To Cells(Rows.Count, 10).End(xlUp).Row
>　　　　　　　　If Range("G" & x1).Value = "数" Then
>　　　　　　　　　　Range("J" & x1).Value = "送"
>　　　　　　　　
>　　　　　　　　End If
>　　　　　　Next
>　　　　　　
>　　　　End If　　　'★
>　　　　
>　　End If　　　　　'★
>　　
>　　Workbooks("C.xls").Close SaveChanges:=True
>　　
>　　Workbooks("B.xls").Close SaveChanges:=False
>　　
>　　Application.ScreenUpdating = True
>　　
>　　If done Then
>　　　　MsgBox "終わりました"
>　　Else
>　　　　MsgBox "Sheet2に処理すべきデータはありませんでした"
>　　End If

・ツリー全体表示


	【76706】Re:Excel2010 データインポートの際デー...

β - 15/3/1(日) 7:56 -


	引用なし

	パスワード

▼りえさん：

ご希望なので。
先にコメントしたところも含めて、コードは、すべて元のままにしてあります。
気になるところも多々ありますが・・・・・・
Sheet1 は必ず処理されるんだということですから、Sheet2　の部分だけを以下。

　　'sheet2
　　Dim ws3 As Worksheet, ws4 As Worksheet
　　Dim r1 As Range
　　Dim n1 As Long
　　Dim i1 As Long, j1 As Long, k1 As Long
　　Dim done As Boolean　　　　 '★
　　
　　Set ws3 = Workbooks("C.xls").Worksheets("Sheet2")
　　Set ws4 = Workbooks("B.xls").Worksheets("Sheet2")
　　Set r1 = ws4.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
　　
　　If Not r1 Is Nothing Then　 '★
　　
　　　　n1 = Int((r1.Row - 2) / 20)
　　　　
　　　　If n1 >= 0 Then　　　　 '★
　　　　　　
　　　　　　done = True　　　　 '★
　　　　　　
　　　　　　Application.ScreenUpdating = False
　　　　　　For i1 = 0 To n1
　　　　　　　　If i1 > 0 Then ws3.Range("A1:J33").Copy ws3.Cells(33 * i1 + 1, 1)
　　　　　　　　For j1 = 1 To 9
　　　　　　　　　　If j1 = 1 Then k1 = j1 Else k1 = j1 + 1
　　　　　　　　　　ws3.Cells(33 * i1 + 12, k1).Resize(20).Value = _
　　　　　　　　　　ws4.Cells(20 * i1 + 2, j1).Resize(20).Value
　　　　　　　　Next
　　　　　　Next
　　　　　　
　　　　　　Dim x1 As Long
　　　　　　For x1 = 1 To Cells(Rows.Count, 10).End(xlUp).Row
　　　　　　　　If Range("G" & x1).Value = "数" Then
　　　　　　　　　　Range("J" & x1).Value = "送"
　　　　　　　　
　　　　　　　　End If
　　　　　　Next
　　　　　　
　　　　End If　　　'★
　　　　
　　End If　　　　　'★
　　
　　Workbooks("C.xls").Close SaveChanges:=True
　　
　　Workbooks("B.xls").Close SaveChanges:=False
　　
　　Application.ScreenUpdating = True
　　
　　If done Then
　　　　MsgBox "終わりました"
　　Else
　　　　MsgBox "Sheet2に処理すべきデータはありませんでした"
　　End If

・ツリー全体表示


	【76705】Re:Excel2010 データインポートの際デー...

β - 15/3/1(日) 7:40 -


	引用なし

	パスワード

▼りえさん：

>各ｼｰﾄには罫線で囲われた表があり、
>20行毎にデータをインポートしています
>各ｼｰﾄのフォーマットを維持したままやりたく思います

別だしにしていますが、実行内容は元コードと全く同じですけど？
なので、アップしたコードでフォーマットが壊れることはないと思いますが？？

>私が質問をさせて頂いたｺｰﾄﾞの構成のままで
>お願い出来ませんか？

ご希望ということなら、後ほどアップします。

・ツリー全体表示


	【76704】Re:Excel2010 データインポートの際デー...

りえ - 15/3/1(日) 7:36 -


	引用なし

	パスワード

β様

回答ありがとうございます

私が質問をさせて頂いたｺｰﾄﾞの構成のままで
お願い出来ませんか？

各ｼｰﾄには罫線で囲われた表があり、
20行毎にデータをインポートしています
各ｼｰﾄのフォーマットを維持したままやりたく思います

お手数ばかりおかけして申し訳ありません

>了解です。
>
>想像で書いているところもありますので当方の誤解あれば指摘願います。
>また、書いただけで動かしてはいません。不具合あれば指摘願います。
>
>・もとのコードの構成のまま、途中で処理をうちきらずに、続行させることもできますが
>　全体の制御が見えにくくなると思いましたので、処理部分をサブプロシジャ
>　（実行したかどうかの戻り値付）にして外だしにしました。
>
>・かつ、Sheet1側、Sheet2側ともに、対象シートが異なるだけで、全く同じ処理でしたので
>　一本化しました。
>
>・コード中にもコメント入れましたが
>
>　　For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
>　　　　If Range("G" & x).Value = "数" Then
>　　　　　　Range("J" & x).Value = "送"
>　　　　End If
>　　Next
>
>　ここだけ、それぞれのセルが、どのシートかの指定がありません。
>　追加しておいてください。
>
>Sub ボタン1_Click()
>　　Dim done As Boolean
>　　Dim bkB As Workbook
>　　Dim bkC As Workbook
>　　
>　　Application.ScreenUpdating = False
>　　
>　　Set bkB = Workbooks.Open("C:\東京\B.xls")
>　　Set bkC = Workbooks.Open("C:\東京\C.xls")
>　　
>　　'sheet1
>　　done = Proc(bkC.Worksheets("Sheet1"), bkB.Worksheets("Sheet1"))
>　　'sheet2
>　　done = Proc(bkC.Worksheets("Sheet2"), bkB.Worksheets("Sheet2"))
>　　
>　　bkB.Close SaveChanges:=False
>
>　　If done Then
>　　　　Application.DisplayAlerts = False
>　　　　bkC.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\" & bkC.Name
>　　　　Application.DisplayAlerts = True
>　　End If
>　　
>　　bkC.Close SaveChanges:=False
>　　
>　　Application.ScreenUpdating = True
>　　
>　　If done Then
>　　　　MsgBox "終わりました"
>　　Else
>　　　　MsgBox "処理すべきデータがありませんでした"
>　　End If
>　　
>End Sub
>
>Private Function Proc(sh1 As Worksheet, sh2 As Worksheet) As Boolean
>
>　　Dim r As Range
>　　Dim n As Long
>　　Dim i As Long, j As Long, k As Long
>　　Dim x As Long
>　　
>　　Set r = sh2.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
>　　
>　　If r Is Nothing Then Exit Function
>　　
>　　n = Int((r.Row - 2) / 20)
>　　If n < 0 Then Exit Function
>　　
>　　Proc = True　　 '★実行された
>
>　　For i = 0 To n
>　　　　If i > 0 Then sh1.Range("A1:J33").Copy sh1.Cells(33 * i + 1, 1)
>　　　　For j = 1 To 9
>　　　　　　If j = 1 Then k = j Else k = j + 1
>　　　　　　sh1.Cells(33 * i + 12, k).Resize(20).Value = _
>　　　　　　sh2.Cells(20 * i + 2, j).Resize(20).Value
>　　　　Next
>　　Next
>　　
>　　'★以下の Cellsと2つのRange。どのシートでしょう？ここにも、sh1. なり sh2.なりを付けてください。
>　　
>　　For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
>　　　　If Range("G" & x).Value = "数" Then
>　　　　　　Range("J" & x).Value = "送"
>　　　　End If
>　　Next
>
>End Function

・ツリー全体表示


	【76703】Re:Excel2010 データインポートの際デー...

β - 15/3/1(日) 7:11 -


	引用なし

	パスワード

▼りえさん：

Main処理のみコード差し換えてください。

Sub ボタン1_Click()
　　Dim done1 As Boolean
　　Dim done2 As Boolean
　　Dim bkB As Workbook
　　Dim bkC As Workbook
　　
　　Application.ScreenUpdating = False
　　
　　Set bkB = Workbooks.Open("C:\東京\B.xls")
　　Set bkC = Workbooks.Open("C:\東京\C.xls")
　　
　　'sheet1
　　done1 = Proc(bkC.Worksheets("Sheet1"), bkB.Worksheets("Sheet1"))
　　'sheet2
　　done2 = Proc(bkC.Worksheets("Sheet2"), bkB.Worksheets("Sheet2"))
　　
　　bkB.Close SaveChanges:=False

　　If done1 Or done2 Then
　　　　Application.DisplayAlerts = False
　　　　bkC.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\" & bkC.Name
　　　　Application.DisplayAlerts = True
　　End If
　　
　　bkC.Close SaveChanges:=False
　　
　　Application.ScreenUpdating = True
　　
　　If done1 Or done2 Then
　　　　MsgBox "終わりました"
　　Else
　　　　MsgBox "処理すべきデータがありませんでした"
　　End If
　　
End Sub

・ツリー全体表示


	【76702】Re:Excel2010 データインポートの際デー...

β - 15/3/1(日) 6:49 -


	引用なし

	パスワード

▼りえさん：

了解です。

想像で書いているところもありますので当方の誤解あれば指摘願います。
また、書いただけで動かしてはいません。不具合あれば指摘願います。

・もとのコードの構成のまま、途中で処理をうちきらずに、続行させることもできますが
　全体の制御が見えにくくなると思いましたので、処理部分をサブプロシジャ
　（実行したかどうかの戻り値付）にして外だしにしました。

・かつ、Sheet1側、Sheet2側ともに、対象シートが異なるだけで、全く同じ処理でしたので
　一本化しました。

・コード中にもコメント入れましたが

　　For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
　　　　If Range("G" & x).Value = "数" Then
　　　　　　Range("J" & x).Value = "送"
　　　　End If
　　Next

　ここだけ、それぞれのセルが、どのシートかの指定がありません。
　追加しておいてください。

Sub ボタン1_Click()
　　Dim done As Boolean
　　Dim bkB As Workbook
　　Dim bkC As Workbook
　　
　　Application.ScreenUpdating = False
　　
　　Set bkB = Workbooks.Open("C:\東京\B.xls")
　　Set bkC = Workbooks.Open("C:\東京\C.xls")
　　
　　'sheet1
　　done = Proc(bkC.Worksheets("Sheet1"), bkB.Worksheets("Sheet1"))
　　'sheet2
　　done = Proc(bkC.Worksheets("Sheet2"), bkB.Worksheets("Sheet2"))
　　
　　bkB.Close SaveChanges:=False

　　If done Then
　　　　Application.DisplayAlerts = False
　　　　bkC.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\" & bkC.Name
　　　　Application.DisplayAlerts = True
　　End If
　　
　　bkC.Close SaveChanges:=False
　　
　　Application.ScreenUpdating = True
　　
　　If done Then
　　　　MsgBox "終わりました"
　　Else
　　　　MsgBox "処理すべきデータがありませんでした"
　　End If
　　
End Sub

Private Function Proc(sh1 As Worksheet, sh2 As Worksheet) As Boolean

　　Dim r As Range
　　Dim n As Long
　　Dim i As Long, j As Long, k As Long
　　Dim x As Long
　　
　　Set r = sh2.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
　　
　　If r Is Nothing Then Exit Function
　　
　　n = Int((r.Row - 2) / 20)
　　If n < 0 Then Exit Function
　　
　　Proc = True　　 '★実行された

　　For i = 0 To n
　　　　If i > 0 Then sh1.Range("A1:J33").Copy sh1.Cells(33 * i + 1, 1)
　　　　For j = 1 To 9
　　　　　　If j = 1 Then k = j Else k = j + 1
　　　　　　sh1.Cells(33 * i + 12, k).Resize(20).Value = _
　　　　　　sh2.Cells(20 * i + 2, j).Resize(20).Value
　　　　Next
　　Next
　　
　　'★以下の Cellsと2つのRange。どのシートでしょう？ここにも、sh1. なり sh2.なりを付けてください。
　　
　　For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
　　　　If Range("G" & x).Value = "数" Then
　　　　　　Range("J" & x).Value = "送"
　　　　End If
　　Next

End Function

・ツリー全体表示


	【76701】Re:Excel2010 データインポートの際デー...

りえ - 15/3/1(日) 6:45 -


	引用なし

	パスワード

β様
回答ありがとうございます

sheet1側で処理すべきデータですが、sheet1には必ずデータがあります
sheet2側には必ずデータがあるわけではありません

また保存ブック名の件ですが、大変失礼しました
拡張子を省いてすみませんでした
C.xlsになります
そして元々開いていたC.xlsと同一の名前です

β さん：
>▼りえさん：
>
>おはようございます
>
>コード案を提示する前に、ご自身で問題提起されている件の他に確認させてください。
>
>・Sheet1側で処理すべきデータがなかった場合、たとえSheet2側で処理するデータがあったとしても
>　処理せず終了していますが、これはいいのですか？
>・Sheet1側処理が終わった後の保存ブック名、「C」ではなく「C.xls」とファイル拡張子も明記したほうがよろしいかと思います。
>　で、この名前は C.xls というより、元々開いた C.xls と同じ名前ということでいいですね？

・ツリー全体表示


	【76700】Re:Excel2010 データインポートの際デー...

β - 15/3/1(日) 6:16 -


	引用なし

	パスワード

▼りえさん：

おはようございます

コード案を提示する前に、ご自身で問題提起されている件の他に確認させてください。

・Sheet1側で処理すべきデータがなかった場合、たとえSheet2側で処理するデータがあったとしても
　処理せず終了していますが、これはいいのですか？
・Sheet1側処理が終わった後の保存ブック名、「C」ではなく「C.xls」とファイル拡張子も明記したほうがよろしいかと思います。
　で、この名前は C.xls というより、元々開いた C.xls と同じ名前ということでいいですね？

・ツリー全体表示


	【76699】Excel2010 データインポートの際データが...

りえ - 15/3/1(日) 4:58 -


	引用なし

	パスワード

3つのファイルがありA.xlsを起動し、A.xls内のマクロの記述を元に、B.xlsとC.xlsを立ち上げています

データのインポートをC.xlsのシート1と2に行なっております
B. xlsにデータがあれば下記コードで問題無ですが、
データがない場合にC.xlsとB.xlsを閉じれません
データがあっても、なくてもC.xlsとB.xlsを閉じ、
データがありませんと表示させたく思います。
VBAで行なうにはどのようにすれば良いでしょうか？

Sub ボタン1_Click()

Application.ScreenUpdating = False

Workbooks.Open ("C:\東京\B.xls")
Workbooks.Open ("C:\東京\C.xls")

'sheet1

　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim r As Range
　　Dim n As Long
　　Dim i As Long, j As Long, k As Long
　　
　　Set ws1 = Workbooks("C.xls").Worksheets("Sheet1")
　　Set ws2 = Workbooks("B.xls").Worksheets("Sheet1")
　　Set r = ws2.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
　　If r Is Nothing Then Exit Sub
　　n = Int((r.Row - 2) / 20)
　　If n < 0 Then Exit Sub
　　Application.ScreenUpdating = False
　　For i = 0 To n
　　　　If i > 0 Then ws1.Range("A1:J33").Copy ws1.Cells(33 * i + 1, 1)
　　　　For j = 1 To 9
　　　　　　If j = 1 Then k = j Else k = j + 1
　　　　　　ws1.Cells(33 * i + 12, k).Resize(20).Value = _
　　　　　　　　　　ws2.Cells(20 * i + 2, j).Resize(20).Value
　　　　Next
　　Next
　　
Dim x As Long
For x = 1 To Cells(Rows.Count, 10).End(xlUp).Row
If Range("G" & x).Value = "数" Then
　Range("J" & x).Value = "送"

End If
Next
　　　　　　　
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="\\サーバ名\フォルダ名1\共有フォルダ名2\C"
Application.DisplayAlerts = True

'sheet2
Dim ws3 As Worksheet, ws4 As Worksheet
Dim r1 As Range
Dim n1 As Long
Dim i1 As Long, j1 As Long, k1 As Long

Set ws3 = Workbooks("C.xls").Worksheets("Sheet2")
Set ws4 = Workbooks("B.xls").Worksheets("Sheet2")
Set r1 = ws4.Range("A:I").Find("*", , xlValues, xlPart, xlByRows, xlPrevious)
If r1 Is Nothing Then Exit Sub
n1 = Int((r1.Row - 2) / 20)
If n1 < 0 Then Exit Sub
Application.ScreenUpdating = False
For i1 = 0 To n1
If i1 > 0 Then ws3.Range("A1:J33").Copy ws3.Cells(33 * i1 + 1, 1)
For j1 = 1 To 9
If j1 = 1 Then k1 = j1 Else k1 = j1 + 1
ws3.Cells(33 * i1 + 12, k1).Resize(20).Value = _
ws4.Cells(20 * i1 + 2, j1).Resize(20).Value
Next
Next

Dim x1 As Long
For x1 = 1 To Cells(Rows.Count, 10).End(xlUp).Row
If Range("G" & x1).Value = "数" Then
　Range("J" & x1).Value = "送"

　End If
　Next
　　　　　　　　　　
Workbooks("C.xls").Close SaveChanges:=True

Workbooks("B.xls").Close SaveChanges:=False

Application.ScreenUpdating = True
MsgBox "終わりました"

End Sub

・ツリー全体表示


	【76698】Re:セルの内容が変わったときの記述方法

gg56 - 15/2/28(土) 8:02 -


	引用なし

	パスワード

独覚さま
丁寧な解説をありがとうございます。
理解して応用範囲を広げていきたいと思います。

・ツリー全体表示


	【76697】Re:アクティブセルの値を読みこんで指定...

β - 15/2/27(金) 14:40 -


	引用なし

	パスワード

▼さとちぃさん：

こんにちは
以下を参考にしてください。
（セルの指定方法は、ほかにもさまざまあります）

Sub Test()
　　'コピペなら
　　ActiveCell.Copy Range("B3")
　　'値の転記のみでよければ
　　Range("B3").Value = ActiveCell.Value
　　
　　'アクティブセルの同一行の右に１０離れたセルを
　　'コピペなら
　　ActiveCell.Offset(, 10).Copy Range("B4")
　　'値の転記のみでよければ
　　Range("B4").Value = ActiveCell.Offset(, 10).Value

・ツリー全体表示


	【76696】Re:アクティブセルの値を読みこんで指定...

さとちぃ - 15/2/27(金) 14:27 -


	引用なし

	パスワード

すみません、先ほどの質問に合わせ、以下の件もご質問したく存じます。

アクティブセル及びアクティブセルから右に10個目のセルの値を読み込み、それぞれB3、B4のセルにコピーする。

アクティブセルの値をうまく読み込めず、おそらくはオフセットを使用して設定する
と思うのですが、うまくいきません。

こちらも教えていただけますでしょうか？

・ツリー全体表示


	【76695】Re:文字数の多い検索ワードから少ない文...

さとちぃ - 15/2/27(金) 14:21 -


	引用なし

	パスワード

KANABUN様

さとちぃです。
今回もいろいろと教えていただきましてありがとうございました。

アクティブセルの設定がまずかったのですね・・・。
大変勉強になりました。

本当にありがとうございました。

・ツリー全体表示


	【76694】アクティブセルの値を読みこんで指定先の...

さとちぃ - 15/2/27(金) 14:19 -


	引用なし

	パスワード

すみません、基本的なご質問かもしれませんが、どうしてもわからず
こちらの方に投稿させていただきました。

アクティブセルの値を読み込み、コピー先を指定して値を貼り付けたいと思います。

Sub　アクティブセルの値を読みこんでコピー()
Dim d As String
d = ActiveCell.Value

Range("D8:D1200").ActiveCell.Select

Selection.Copy
Range("B3").Select
ActiveSheet.Paste

End Sub

アクティブセルの値の選択について、やり方が分からず困っております。
教えていただけませんでしょうか？

・ツリー全体表示


	【76693】Re:セルの内容が変わったときの記述方法

独覚 - 15/2/27(金) 13:10 -


	引用なし

	パスワード

▼gg56 さん：

For Eachを使っているのはセル範囲を選択してCtrl+Enterでまとめて値を入力したりセル範囲を選択して
Deleteしたりと、Targetが一つのセルではなくセル範囲になる可能性があるからです。

もし、必ず一つのセルしか変更しないならばFor Eachを外して中の部分だけでいいことになります。

(For Eachはセル範囲に対応するためなので変更したセルに対応する列の色変更はFor Each の中の部分になります)

・ツリー全体表示


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

286 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free