- ベストアンサー
マクロ修正お願いします。
Wendy02の回答
- Wendy02
- ベストアンサー率57% (3570/6232)
こんばんは。 もともと、セル位置などは分かりませんので、こちらのサンプルを出して、それを例にさせていただきますから、後は、ご自身で直してください。 以下のマクロの変更部分の説明 Sh2.Cells(j, 2).Value = Sh1.Cells(i, 2).Value '氏名 ↑ ↑ 列の番号(B列) 列の番号(B列) シート2 と シート1 では違う部分もあるかと思いますが、それは、それぞの列番号を入れてください。 以下は、ほんの一例です。 Sheet1 A B C D F 異動 氏名 コード 部署 tel Sub TestSample2() Dim Sh1 As Worksheet, Sh2 As Worksheet Dim r As Range, c As Range, i As Long, j As Long Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range("A2", Sh1.Range("A65536").End(xlUp)) Select Case c.Value Case "入社" c.Offset(, 1).Resize(, 255).Copy Sh2.Range("A2").End(xlDown).Offset(1) 'B列より、右端255行を、シート2のA列の最後尾の次にコピーする。 Case "異動" Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole) If Not r Is Nothing Then i = c.Row 'Sheet1 側の該当行 j = r.Row 'Sheet2 側の該当行 '変更部分 Sh2.Cells(j, 2).Value = Sh1.Cells(i, 2).Value '氏名 Sh2.Cells(j, 3).Value = Sh1.Cells(i, 3).Value 'コード Sh2.Cells(j, 4).Value = Sh1.Cells(i, 4).Value '部署 Sh2.Cells(j, 5).Value = Sh1.Cells(i, 5).Value 'tel End If 'コードを検索して、その見つかったものを上書き Case "退社" Set r = Sh2.Columns(1).Find(c.Offset(, 1).Value, , xlValues, xlWhole) If Not r Is Nothing Then r.EntireRow.Delete 'コードを検索して、その見つかったものを削除 End Select Next End Sub
関連するQ&A
- どなたかマクロ修正お願いします。
自分なりに 作成してみましたがどうもうまくいきません。 Sub 変換() Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet, Dim r As Range Set Sh1 = Worksheets("1") Set Sh2 = Worksheets("2") Set Sh3 = Worksheets("3") Sh3.Select Set c = Cells.Find(What:="9876543", LookAt:=xlWhole) c.Offset(, 1).Activate ActiveCell.Replace What:="中田", Replacement:="中田英寿" End Sub このように作成しましたがうまくいきません。恐らくsheet3のデータはsheet1から（ =1!A100 )といったように値を他のsheetから持ってきてるからではないんでしょうか？
- ベストアンサー
- オフィス系ソフト
- VBA マクロ シート 転記
はじめまして。VBA初心者です。今シート１のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート２のＢ列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート２の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。 Sub 転記() Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range Dim LastRow As Long, i As Long, er As Long, wkey As String Set ws = Worksheets("Sheet1") Set ws1 = Worksheets("Sheet2") LastRow = ws.Range("A1").End(xlDown).Row er = ws1.Range("A1").End(xlDown).Row Set r = ws.Range("A1:A" & LastRow) For i = 1 To er wkey = ws1.Range("A" & i) Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole) If Not r1 Is Nothing Then ws1.Range("B" & i) = r1.Offset(, 1) End If Next Set r1 = Nothing Set r = Nothing Set ws = Nothing Set ws1 = Nothing End Sub どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか？宜しくお願いします。
- ベストアンサー
- Visual Basic
- 2つのマクロを1つにしたい
いつもお世話になっております。 今回もよろしくお願いいたします。 (1)14のシートがあるのですが、データーのある2から14までのシートを印刷する。 (2)上記のうち、ｃ列のデーターで連続しているセルを結合する。 (1)と(2)を合わせて1つのマクロにしたいのですが、アクティブシート１つにしか(2)のマクロが動きません。 下記のコードの間違いを教えてください。 Sub 契約書目次印刷() Dim Sh As Worksheet Dim t As Long Dim i As Range t = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'データーのあるシートだけ印刷 For Each Sh In Worksheets(Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14)) If Sh.Range("A2").Value <> "" Then '連続データーセル結合 For Each i In Range("C1:C" & t) If i.MergeArea(1).Value = i.Offset(1).Value Then Range(i.MergeArea, i.Offset(1)).Merge End If Application.DisplayAlerts = False Next i End If Sh.PrintPreview Next Sh End Sub
- ベストアンサー
- Excel（エクセル）
- マクロの関係で困ってしまいました。印刷できません
Sub Sample3() Dim i As Long, k As Long, c As Range, r As Range i = InputBox("入替え元番号を入力") k = InputBox("入替え先番号を入力") Set c = Range("A:A").Find(what:=i, LookIn:=xlValues, lookat:=xlWhole) Set r = Range("A:A").Find(what:=k, LookIn:=xlValues, lookat:=xlWhole) On Error Resume Next If c.Row < r.Row Then i = c.Row k = r.Row Else i = r.Row k = c.Row End If Rows(k + 1).Insert Rows(i).Cut Cells(k + 1, "A") Rows(k).Cut Cells(i, "A") Rows(k).Delete End Sub 上記のようなマクロを組んで頂いたのですが、「改ページ位置を移動できません」という状況になっています。せっかくgooの質問で答えて頂いたのですが、これでやったら８０行ぐらいから、この表示が出て、解決できません。どなたか、解決して頂けませんか。その時に補足すればよかったのですが、動かしてみて分かった次第です。お答え頂いた方に大変申し訳なく思っています。よろしくお願いします。 なお、間違った入力をしてしまった時に、一回だけは元に戻るなんてことはできないですかね。これもできたら厚かましいですがお答え頂けたらと思います。
- ベストアンサー
- Excel（エクセル）
- EXCELマクロのこの記述の意味を教えてください。
こんにちは。 以前、教えてもらったマクロですが もう少し深く勉強したいので、記述の 意味（翻訳？）を教えてください。 Sub Test5() Dim FR1 As Range, FR2 As Range With ActiveSheet Set FR1 = .Cells.Find( _ "*", , xlValues, xlWhole, xlByRows, xlPrevious) Set FR2 = .Cells.Find( _ "*", , xlValues, xlWhole, xlByColumns, xlPrevious) End With Range("A1", Cells(FR1.Row, FR2.Column)).Select Set FR1 = Nothing: Set FR2 = Nothing End Sub また、この範囲をA列だけを見る場合、つまりA列の最終行を範囲とする場合は、どう記述すればよいのでしょうか？ ぜひ、教えてください。
- ベストアンサー
- オフィス系ソフト
- ExcelVBA データのコピー範囲について
あけましておめでとうございます。今年もよろしくお願いします。 Sub Test() Dim myTarget As Range, r As Range, f Set myTarget = Sheets("Sheet1"). _ Range("B2", Sheets("Sheet1").Range("B65536").End(xlUp)) For Each r In myTarget Set f = Sheets("Sheet2").Columns(1). _ Find(r.Value, Sheets("Sheet2").Range("A1"), Lookat:=xlWhole) If Not f Is Nothing Then If r.Offset(0, 3).Value <> f.Offset(0, 3).Value Then f.Resize(1, 4).Copy Destination:= _ Sheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0) End If End If Next r End Sub 前回の質問で教えていただいたコードなのですが、現時点では、B列のデータを元にして二つのSheetのデータを比較して別Sheetへコピーしているのですが、そのときに、B列以降の（たとえば、B列からX列まで）データはコピーできますが、A列もコピーしたい時はどうすればよいのかで、悩んでいます。どの様に変更すればよいのでしょうか？
- ベストアンサー
- オフィス系ソフト
- エクセルの簡単なマクロ機能を追加したいのです
既存のエクセルマクロ（Sub チェック()以下です）に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です： Sheet2のC列に 0 があれば Sheet1のB列に 愛 と（[太字]でセルの背景色を[灰色25%]にして）入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub
- 締切済み
- その他MS Office製品
- ExcelVBAマクロでのデータの受け渡し
Sheet1「元データ」 A B C D 1 0001 みかん A店 3/1 2 0200 りんご B店 3 0311 いちご B店 3/10 4 いちじく C店 5 0360 メロン D店 6 かき P店 7 0312 キウイ D店 Sheet2「最新データ」 A B C D 1 0001 みかん A店 3/1 2 0190 3 0200 4 0311 いちご B店 3/10 5 0422 洋ナシ C店 6 0250 7 0500 すいか P店 8 0312 キウイ とあった時に最新データのA列の番号と元データの番号を見て同じ物があったら、最新データに元データの内容をうつし込むというデータがあります。 Dim Sh1 As Worksheet Dim Sh3 As Worksheet Dim myR As Range Dim N_D As Long Dim i As Long Set Sh1 = Worksheets("元データ") Set Sh3 = Worksheets("最新データ") With Sh3 For i = 5 To .Range("A65536").End(xlUp).Row N_D = .Range("E" & i).Value Set myR = Sh1.Range("A:A").Find(What:=N_D, LookIn:=xlValues, _ MatchCase:=False) If Not myR Is Nothing Then .Range("B" & i & ":D" & i).Value = _ myR.Offset(, 2).Resize(, 3).Value End If Next End With Set Sh1 = Nothing Set Sh3 = Nothing ここで、値は普通にコピーされてくるのですが、 フォントに色がついていたら、その色もつけたいのですが、どうすれば良いのか分らず困っています。 方法がありましたら、教えてください。 よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- マクロについて質問です。
A B C 1 3 りんご 2 赤 3 くだもの 4 6 みかん 5 オレンジ 6 くだもの 7 9 ぶどう 8 紫 9 くだもの というデータがシート1にあったとして、シート2のa2セルに6と入力すると以下のようにa5セル以降に抽出し、6という入力を消すと抽出したものも消えるようなマクロ 6 みかん オレンジ くだもの 上のような質問で下のマクロを教えていただけたのですが、もし、みかんのb列も3だった場合いしたのようにみかんの行まで抽出できるようにするには下の構文をどうかえたらよいでしょうか。下手くそな質問ですがよろしくお願いします。 3 りんご 赤 くだもの みかん オレンジ くだもの 現在、わかっている構文↓ Private Sub Worksheet_Change(ByVal Target As Range) 'この行から Dim c As Range, wS As Worksheet Set wS = Worksheets("Sheet1") With Target If .Address = "$A$2" Then If .Value <> "" Then Set c = wS.Range("B:B").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then c.Offset(, 1).Resize(3).Copy Range("A5") Else MsgBox "該当データなし" End If Else Range("A5").Resize(3).ClearContents End If End If End With End Sub 'この行まで
- ベストアンサー
- Excel（エクセル）
- ExcelVBAで画像の様に動作を変更したいです
先日、こちらにて 教えていただいたマクロでのデータ突合方法を基にマクロを作成中なのですが、 画像の様に動作させるにはどう修正すればよいでしょうか （目標） 画像のSheet1 と Sheet2の商品コードを上から順に突合し、 Sheet3に合致したA品番をコピー Sheet4に合致したB品番をコピー Sheet5に合致しなかったA品番をコピー Sheet6に合致しなかったB品番をコピー ※なお、A品番B品番ともに同じ値の品番がいくつか存在することがある。 この場合は、ループ中既に合致したデータは対象から外す。 判別方法は品番の一つ横のセルに”〇”を表記。（フラグを立てる） 「A品番＝B品番」のとき「Offset(0, 1)が”〇”」ならば合致しない --------------------------------------------------- （手順） (1)Sheet1 あり Sheet2 ありの場合 →一致したSheet1とSheet2のOffset(0, 1)に”〇” →一致したSheet1の行全体の値をSheet3にコピー →一致したSheet2の行全体の値をSheet4にコピー (2)Sheet1 あり Sheet2 なしの場合 →該当するSheet1の行全体の値をSheet5にコピー (3)Sheet1 なし Sheet2 ありの場合 →該当するSheet2の行全体の値をSheet6にコピー --------------------------------------------------- （現在のコード） Sub Test() Dim c As Range, FRange As Range Dim Sh1 As Worksheet, Sh2 As Worksheet Set Sh1 = Worksheets("Sheet1") Set Sh2 = Worksheets("Sheet2") For Each c In Sh1.Range(Sh1.Cells(3, "A"), Sh1.Cells(Rows.Count, "A").End(xlUp)) Set FRange = Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)). _ Find(c.Value, LookAt:=xlWhole, After:=Sh2.Cells(Rows.Count, "A").End(xlUp)) If Not FRange Is Nothing Then If c.Value = FRange.Value And FRange.Offset(1, 0).Value <> "◯" Then c.Offset(0, 1).Value = "◯" '↓(1).xlsmSheet2に Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value FRange.Offset(0, 1).Value = "◯" End If Else '↓(1).xlsmのSheet3に Sheets("Sheet5").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next For Each c In Sh2.Range(Sh2.Cells(3, "A"), Sh2.Cells(Rows.Count, "A").End(xlUp)) If c.Offset(0, 1).Value = "◯" Then '↓(2).xlsmのSheet2に Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value Else '↓(2).xlsmのSheet3に Sheets("Sheet6").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = c.Value End If Next End Sub ご指導頂ければ幸いです。
- ベストアンサー
- Excel（エクセル）