• ベストアンサー
  • すぐに回答を!

データの入力規制

以前教えていただきました。データの入力規制ですが、変更があったため、再度 教えていただけますでしょうか? sheet2のB列にデータの入力規制のセルを設け、そこに頭文字をいれると、sheet1のリストの中から その頭文字とマッチしたリストを表示させるものを作りたいと考えています。 前回はsheet2のA列に候補のリストがありましたが、今回はsheet1のB列にリストがあります。 また、前回はsheet1のA列にリスト設定していましたが、今回はsheet2のB列に変更したいとおもってます。 また、前回はsheet1のC列にマッチした候補が表示していましたが、 sheet1のAK列までデータが入っており、使えなくなっております。 前回教えていただいたコードが Sub リスト() 'この行から Dim i As Long, cnt As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") '←Sheet1は実際のSheet名に! Set wS2 = Worksheets("Sheet2") '←Sheet2も実際のSheet名に! i = wS2.Cells(Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False If i > 1 Then Range(wS2.Cells(2, "C"), wS2.Cells(i, "C")).ClearContents End If cnt = 1 If Selection.Column = 1 And Selection.Count = 1 Then For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If wS2.Cells(i, "A") Like Selection & "*" Then cnt = cnt + 1 wS2.Cells(cnt, "C") = wS2.Cells(i, "A") End If Next i Application.ScreenUpdating = True End If End Sub 'この行まで になります。 追伸、今朝、お答えいただいた方、申し訳ございません。 画像を他のページから貼ってしまったため、削除されてしまいました。 ですので、再度質問させていただきます。

共感・応援の気持ちを伝えよう!

  • 回答数2
  • 閲覧数126
  • ありがとう数1

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.2
  • tom04
  • ベストアンサー率49% (2537/5117)

No.1です。 補足の >sheet1のB列のデータに同じ名称が2つ以上の場合が とありますので、 前回のコード内の >If StrConv(wS.Cells(i, "B"), vbKatakana) Like StrConv(Selection, vbKatakana) & "*" Then の行を If StrConv(wS.Cells(i, "B"), vbKatakana) Like StrConv(Selection, vbKatakana) & "*" And _ WorksheetFunction.CountIf(wS.Range("AL:AL"), wS.Cells(i, "B")) = 0 Then に変更してみてください。m(_ _)m

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • Excel 2007 マクロのIF構文について

    Excel 2007 マクロのIF構文について Sheet1からSheet2にIF構文を使用して、 必要な情報を転記するマクロです。 下記マクロで実現できているのですが、IF構文が多く もっと効率的なマクロがあるのではないかと考えています。 IF構文が2つありますが、1つにまとめるマクロがありましたら お教えください。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '「Sheet1」シートを更新 Worksheets("Sheet1").Range("A1").ListObject.QueryTable.Refresh BackgroundQuery:=False '「Sheet1」シートから「Sheet2」シートに転記 For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, 13).End(xlUp).Row '「Sheet1」シートのL列から「Sheet2」シートのS列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "S") = ws1.Cells(i, "L") End If '「Sheet1」シートのG列から「Sheet2」シートのQ列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "Q") = ws1.Cells(i, "G") End If Next j Next i End Sub

  • Excel 2007 マクロ 別シートの情報を反映する方法

    Excel 2007 マクロ 別シートの情報を反映する方法 Sheet1とSheet2があります。 Sheet1のD列とSheet2のM列で同じ値があれば、 Sheet1のE列の値をSheet2のN列に反映するマクロを 作成しました。 下記が正しいと思っていたのですが、エラーメッセージは出ずに 値が反映されません。 マクロに問題点があればご指摘ください。 よろしくお願いいたします。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") For i = 2 To ws1.Cells(Rows.Count, "D").End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, "M").End(xlUp).Row If ws2.Cells(j, "M") = ws1.Cells(i, "D") Then ws2.Cells(j, "N") = ws1.Cells(i, "E") End If Next j Next i End Sub

  • VBA 高速化

    以下のコードを改良して早く処理できるようにしたいです。素因数分解をして、素因数の数を数えるプログラムです。 Sub 素因数を数える() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim I As Long, j As Long, cnt As Long, wS As Worksheet, k As Long, Set wS = Worksheets("Sheet2") k = Worksheets("Sheet1").Range("A100010").End(xlUp).Row - 1 For dd = 3 To k Call aaa(Range("A" & dd)) Next dd Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Private Sub aaa(ByVal Target As Range) Set wS = Worksheets("Sheet2") If Intersect(Target, Range("A:A")) Is Nothing Or Target.Count > 1 Then Exit Sub With Target If Not IsNumeric(.Value) Then Exit Sub If .Value Mod 1 = 0 Then Range("D1") = .Value For I = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Do While Cells(Rows.Count, "D").End(xlUp) Mod wS.Cells(I, 1) = 0 cnt = cnt + 1 Cells(Rows.Count, "D").End(xlUp).Offset(1) = Cells(Rows.Count, "D").End(xlUp) / wS.Cells(I, 1) Loop If Cells(Rows.Count, "D").End(xlUp) = 1 Then Exit For Next I End If .Offset(, 1) = cnt End With Range("D:D").Clear End Sub 以前教えていただいたコードを使って書きました。 どういう状況で使っているかといいますと、シート1のA列に自然数を2から順番に並べ、シート2のA列に素数を並べておき、プログラムを実行すると、B列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。

その他の回答 (1)

  • 回答No.1
  • tom04
  • ベストアンサー率49% (2537/5117)

こんばんは! 今回はひらがな・カタカナが混在しているようですので、 どちらの文字でも1文字以上入力すると、両方が表示されるようにしてみました。 まずAlt+F11キー → メニュー → 挿入 → 標準モジュール → VBE画面に ↓のコードをコピー&ペーストしておいてください。 Sub リスト() Dim i As Long, cnt As Long, wS As Worksheet Set wS = Worksheets("Sheet1") i = wS.Cells(Rows.Count, "AL").End(xlUp).Row '←リスト表示列を変更 Application.ScreenUpdating = False If i > 1 Then Range(wS.Cells(2, "AL"), wS.Cells(i, "AL")).ClearContents End If cnt = 1 For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row If StrConv(wS.Cells(i, "B"), vbKatakana) Like StrConv(Selection, vbKatakana) & "*" Then '←B列がリスト候補 cnt = cnt + 1 wS.Cells(cnt, "AL") = wS.Cells(i, "B") '←Sheet1のB列データをAL列に表示 End If Next i Application.ScreenUpdating = True End Sub 次にSheet2のシートモジュールに↓のコードを! Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 2 And Target.Count = 1 Then '←列をB列(2)に変更 Call リスト End If End Sub 最後にSheet2の入力規則の「元の値」の欄に =OFFSET(Sheet1!AL$1,1,,COUNTA(Sheet1!AL:AL)-1) これで何とかご希望に近い形にならないでしょうか? ※ 今回も一旦データを入力 → Enter → 元のセルに戻る という操作になってしまいます。m(_ _)m

共感・感謝の気持ちを伝えよう!

質問者からのお礼

おはようございます。 無事に動きました。いろいろとお手数おかけしました。 本当にありがとうございます。 また、お力お借りするすることがあるとおもいますが、 またよろしくお願いいたします。

質問者からの補足

こんばんは~。返事が遅れて申し訳ございません。 無事に動かすことができました。本当にたすかりました。ありがとうございます。 大変申し訳ないのですが。 ちょっと困ったことがおきまして、sheet1のB列のデータに同じ名称が2つ以上の場合が あるのですが、リストにすべて表示されてしまうので、1つ表示にしたいのですが可能なのでしょうか? お手数おかけして申し訳ございません。

関連するQ&A

  • 置換のマクロ

    すみません、基礎的なことかもしれませんが、 調べてもわかりませんでした… 下記マクロで、今はwS1のA列に置換したい文字があった場合 置換をしてくれますが、 A列だけではなく、wS1のシート全体を指定する為にはどのように書き換えればいいでしょうか…? Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A") の wS1.Cells(i, "A") を Aではなく、シート全体の指定に変えたいのです。。 Sub 置換() Dim i As Long, k As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = ActiveSheet Set wS2 = Worksheets("置換") Application.ScreenUpdating = False For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row For k = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If InStr(wS1.Cells(i, "A"), wS2.Cells(k, "A")) > 0 Then wS1.Cells(i, "A") = Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A"), wS2.Cells(k, "B")) End If Next k Next i Application.ScreenUpdating = True End Sub 過去の質問↓の回答にあったマクロから、少し変えて使わせていただいています。 http://okwave.jp/qa/q8293972.html

  • シート1の氏名をシート2に反映

    sheet1の氏名をsheet2の日付、記号(A,B,C)にマッチした位置に入力させたいのですが下記コードで他で試したのですがうまくいきません。どなたかコードが解る方よろしくお願いします。 Sub 入力() Dim i As Long, j As Long, k As Long, L As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)) j = wS2.Cells(3, Columns.Count).End(xlToLeft).Column Range(wS2.Cells(3, 2), wS2.Cells(i, j)).ClearContents On Error Resume Next For i = 2 To wS1.Cells(Rows.Count, 4).End(xlUp).Row If WorksheetFunction.CountA(wS1.Rows(i)) > 1 Then For j = 2 To wS1.Cells(i, Columns.Count).End(xlToLeft).Column If wS1.Cells(i, j) <> "" Then k = WorksheetFunction.Match(wS1.Cells(i, 4), wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)), False) L = WorksheetFunction.Match(wS1.Cells(5, j), wS2.Rows(3), False) wS2.Cells(k, L) = wS1.Cells(i, j) End If Next j End If Next i End Sub

  • セルの値から任意の文字のみを抽出する

    こんにちは。 VBA勉強中です。 どうしても詰まってしまったので力を貸してください。・゜・(ノД`)・゜・。 Sheet1にはA列&#65374;J列にデータが入っています(行数は3行目&#65374;□行目・・・都度変わります) Sheet2には抽出したい文字の一覧(仮に禁止ワードとします)がB列5行目&#65374;○行目まで入ってます。 質問としてはSheet1のB列、D列、F列のそれぞれの値より禁止ワードを抽出する。 1つのセルに禁止ワードが0&#65374;最大5つ入っている時にK列から→方向に禁止ワードを並べて行くといった 感じです。 わかりにくくてすみませんが宜しくお願い致します。 以下自分で考えてみたコードです。。 これだと始めのB列のみ抽出に成功しましたがその他の列からは抽出できず・・・。゜(PД`q。)゜。 列Bで使用したコードをD列、F列にも使えると下に数値のみ変えて羅列しただけだからでしょうか;w; 本当に初心者ですみません。。 以下コードです。 Sub 禁止ワード抽出() Dim SR As Integer , LR As Integer, SR2 As Integer , LR2 As Integer , LR3 As Integer , LR4 As Integer Dim i As Long , j As Long , k As Long , m As Long Dim KINSHI As Variant SR = 3 SR2 =5 LR = Sheets("Sheet1").Range("B" Rows.Count).End(xlUp).Row LR2 = Sheets("Sheet1").Range("D" Rows.Count).End(xlUp).Row LR3 = Sheets("Sheet1").Range("F" Rows.Count).End(xlUp).Row LR4 = Sheets("Sheet2").Range("B" Rows.Count).End(xlUp).Row For j = SR2 To LR4 KINSHI = Sheets("Sheet2").Cells(j , 2).Value For i = SR To LR If Sheets(Sheet1).Cells(i , 2).Value Like ("*" & KINSHI & "*") Then If Cells(i , 10) = "" Then Cells(i , 10) = KINSHI Else   If Cells(i , 10 + 1) = "" Then Cells(i , 10 + 1) = KINSHI            Else   If Cells(i , 10 + 2) = "" Then Cells(i , 10 + 2) = KINSHI Else   If Cells(i , 10 + 3) = "" Then Cells(i , 10 + 3) = KINSHI Else   If Cells(i , 10 + 4) = "" Then Cells(i , 10 + 4) = KINSHI End If End If End If End If End If End If Next i , j 以下上記コードをD列、F列バージョンで並べています・・・・ End Sub 恐らくOffsetプロパティを使う方がいいと思いましたが中々うまくいかず 自分なりに色々考えてみてこんな残念な結果になってしまいましたが 皆様のお力添えどうぞ宜しくお願い致します。

  • VBA 空白表示させたい

    教えて頂いたVBAなのですが Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents If Selection(Selection.Count).Row <> 2 Then Exit Sub Counter = 0 For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j If INP <> "" Then Counter = Counter + 1 wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub ---------------------------------------------------------------------- g      h       i      j パセリ クレソン メキャベツの葉 ごぼう 1      1             1 1                    1 1行目 パセリ,クレソン,メキャベツの葉 2行目  3行目 パセリ,メキャベツの葉 と、2行目は詰めずに空白表示したいです。 どこをどうすればできますか?

  • VBA 検索するSheetの位置の変更

    現在、グループの数だけユーザー名の合計数をSheet2に抽出するという 事をやっているのですが....... コードの方は下記になります Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet1") Set wS3 = Worksheets("Sheet2") Application.ScreenUpdating = False If wS2.Range("Y1") = "" Then wS2.Range("Y1") = "ダミー" End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _ wS2.Cells(7, (i - 2) * 8 + 3)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。 lastRow = .Cells(Rows.Count, "C").End(xlUp).Row Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _ どなたかご教授の方お願い致します。

  • 指定した範囲で0の行を削除するマクロ

    以下のコードで7列目が0の行を削除するマクロを作ったのですが、 13行目以降を削除するように指定できますでしょうか? 1-12行は別のシートに数式を入れているため、削除したくないのですが、 うまくいきません。よろしくお願いいたします。 Sub 行削除() Dim Rw As Long Dim Cnt As Long Application.ScreenUpdating = False For Rw = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1 With Cells(Rw, 7) If .Value = 0 Then .EntireRow.Delete Cnt = Cnt + 1 End If End With Next If Cnt = 0 Then MsgBox "削除対象行は、見つかりません。", vbExclamation Else MsgBox Cnt & " 件見つかり行を削除しました。", vbInformation End If End Sub

  • マクロで最終行を空欄にしたいのですが、出来なくて困ってます

    VBA初心者です。 仕事で、見積書を作成する際に多い時には2~3枚にわたる時で、マクロが既に組んであるのですが、最終行は空欄のはずが、2ページ目のデータが上がってきています。 どうすれば、最終行を空欄に出来るのでしょうか? このマクロが、延々と続いています。 Dim a As Integer Dim c As Integer Dim count As Integer b = 1 c = 1 count = 1 '明細1の処理 a = 1 If Sheet2.Cells(a + 3, 2) = "" Then GoTo 20 Sheet13.Cells(b + 22, 1) = count Sheet13.Cells(b + 22, 2) = Sheet2.Cells(a + 3, 3) Sheet13.Cells(b + 22, 12) = Sheet1.Cells(c + 14, 5) Sheet13.Cells(b + 22, 13) = Sheet1.Cells(c + 14, 6) Sheet13.Cells(b + 22, 17) = Sheet1.Cells(c + 14, 10) If b = 26 Then JUMP1 If b = 74 Then JUMP1 b = b + 1 c = c + 1 count = count + 1 For a = 2 To 8 If Sheet2.Cells(a + 3, 2) = "" Then GoTo 10 Sheet13.Cells(b + 22, 2) = Sheet2.Cells(a + 3, 3) If b = 26 Then JUMP1 If b = 74 Then JUMP1 b = b + 1 Next a 10 If b = 26 Then JUMP1 If b = 74 Then JUMP1 b = b + 1 初心者の為、宜しくお願い致します。

  • excel2003入力したデータを別シートにコピー

    会社でエクセル2003を使っています。 ド素人で、専門用語が全く分からないのでお許しください。 ひな形に入力したデータを その都度、別シートにリストとして保存したいのです。 ネットで調べたところマクロを使うようで Sub 正方形長方形4_Click() Call macro01 Call macro02 End Sub Sub macro01() Dim ws1 As Worksheet, ws2 As Worksheet Dim x As Long, y As Long Set ws1 = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") x = ws2.Cells(Rows.Count, "b").End(xlUp).Row + 1 y = ws1.Cells(Rows.Count, "b").End(xlUp).Row ws1.Cells(21, "b").Resize(y, 9).Copy ws2.Cells(x, "B").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End Sub Sub macro02() Worksheets("Sheet1").PrintOut End Sub いろいろ知らべみてこのようなマクロを作りました。 家のエクセル2010では順番に入力行のその下にデータリストが増えていくのですが 会社の2003だと2行空いてしまうのです。 上記にマクロは家で作って会社ではそのマクロを入力する形です。 マクロの意味が全く分からず、どこを修正すればいいのかもわかりません。 お力をお貸しください。 よろしくお願いいたします。

  • VBA どこでもセル選択

    教えて頂いたVBAなのですがもう一つ Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j Counter = Counter + 1 If INP <> "" Then wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub -------------------------------------------------------------- For i = 3 のところを3としないでどのセル(行)にも対応させたいのですが どうすればいいでしょうか?

  • 【Excel VBA】データ貼り付けの開始位置について

    Excel2003を使用しています。 先日、こちらでアドバイスをいただきながら、下記のようなマクロを作りました。内容はあるセルの値と同じ名前のシートへデータをコピーするというものです。 Sheet1に貼り付け元のデータが表形式であり、必要なデータのみ該当のシートへコピーします。マクロ実行後は、別の新しいデータをSheet1へコピペして、またマクロを実行するのですが、その際、データの貼り付け開始位置を前回マクロを実行して貼り付けられたデータから2行空けたいのですが、可能でしょうか? ________________________________________________________________________________________________________________________________ Sub test3() Dim n As Long Dim i As Long Dim j As Long  Worksheets("Sheet1").Activate   For n = 4 To Cells(Rows.Count, 2).End(xlUp).Row    If Cells(n, 3).Value <> "" Then     With Worksheets(CStr(Cells(n, 3).Value))       i = .Cells(Rows.Count, 3).End(xlUp).Row + 1       Cells(n, 2).Copy .Cells(i, 2)       Cells(n, 7).Resize(, 2).Copy .Cells(i, 4)       Cells(n, 11).Copy .Cells(i, 3)     End With    End If    If Cells(n, 13).Value <> "" Then     With Worksheets(CStr(Cells(n, 13).Value))       j = .Cells(Rows.Count, 3).End(xlUp).Row + 1       Cells(n, 12).Copy .Cells(j, 2)       Cells(n, 17).Copy .Cells(j, 4)       Cells(n, 18).Copy .Cells(j, 6)       Cells(n, 11).Copy .Cells(j, 3)     End With    End If   Next n End Sub