セルデータに基づいて特定のシートにVBAコピー行プラス年齢の並べ替え

Question

私はここでいくつかの助けを受けて、私のコードを更新する必要があります。今は "MASTER"シートの行を新しいシートにコピーします（BLACK、1ST BROWN、...）。私はまだそれをしたいと思いますが、2枚目のシート（BLACK NOTES、1ST BROWN、...）にもコピーしますが、（セルe < = 12）それは "KIDS NOTES" 、1ST BROWN、...）

はここ

Sub RUN_BEFORE_TEST() 

sortlist Macro 

    Dim c As Range 
    Dim j As Integer 
    Dim k As Integer 
    Dim l As Integer 
    Dim m As Integer 
    Dim n As Integer 
    Dim o As Integer 
    Dim p As Integer 
    Dim Source As Worksheet 
    Dim Target As Worksheet 

    j = 11 
    k = 11 
    l = 11 
    m = 11 
    n = 11 
    o = 11 
    p = 11 

    Set Source = ActiveWorkbook.Worksheets("master") 

    ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort.SortFields.Clear 
    ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort.SortFields.Add _ 
     Key:=Range("D10:D110"), SortOn:=xlSortOnValues, Order:=xlAscending, _ 
     DataOption:=xlSortNormal 
    With ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort 
     .Header = xlYes 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 
    ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort.SortFields.Clear 
    ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort.SortFields.Add _ 
     Key:=Range("C10:C110"), SortOn:=xlSortOnValues, Order:=xlAscending, _ 
     DataOption:=xlSortNormal 
    With ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort 
     .Header = xlYes 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 
    Range("B10").Select 
    ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort.SortFields.Clear 
    ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort.SortFields.Add _ 
     Key:=Range("B11:B110"), SortOn:=xlSortOnValues, Order:=xlAscending, _ 
     CustomOrder:= _ 
     "6th Black,5th Black,4th Black,3rd Black,2nd Black,1st Black,Jr. Black,1st Brown,2nd Brown,3rd Brown", _ 
     DataOption:=xlSortNormal 
    With ActiveWorkbook.Worksheets("MASTER").ListObjects("Table2").sort 
     .Header = xlYes 
     .MatchCase = False 
     .Orientation = xlTopToBottom 
     .SortMethod = xlPinYin 
     .Apply 
    End With 

For Each c In Source.Range("b11:b110") 
     If (c = "6th Black" Or c = "5th Black" Or c = "4th Black" Or c = "3rd Black" Or c = "2nd Black" Or c = "1st Black" Or c = "Jr. Black") Then 
      Set Target = ActiveWorkbook.Worksheets("BLACK") 
      Source.Rows(c.Row).Copy Target.Rows(j) 
     ElseIf c = "1st Brown" Then 
      Set Target = ActiveWorkbook.Worksheets("1ST BROWN") 
      Source.Rows(c.Row).Copy Target.Rows(k) 
      k = k + 1 
     ElseIf c = "2nd Brown" Then 
      Set Target = ActiveWorkbook.Worksheets("2ND BROWN") 
      Source.Rows(c.Row).Copy Target.Rows(l) 
      l = l + 1 
     ElseIf c = "3rd Brown" Then 
      Set Target = ActiveWorkbook.Worksheets("3RD BROWN") 
      Source.Rows(c.Row).Copy Target.Rows(m) 
      m = m + 1 
     End If 

     j = j + 1 
     Next c 

Sheets("BLACK").Select 

Set oRng = Range("b11") 

iRow = oRng.Row 
iCol = oRng.Column 

Do 
' 
If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then 
    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown 
    iRow = iRow + 2 
Else 
    iRow = iRow + 1 
End If 
' 
Loop While Not Cells(iRow, iCol).Text = "" 

End Sub 

はあなたのコードが挿入され、ありがとうございました。私が言うことを忘れていたことの1つは、c = *黒の場合、私はそれを「子供たち」に移動させたくないということです。私はコーディングのあなたのスタイルに固執するつもりだ

For Each c In Source.Range("b11:b110") 
' new condition to check cell e 
If (c.Offset(0, 2) <= 12) Then 
    Set Target = ActiveWorkbook.Worksheets("KIDS BROWN NOTES") 
ElseIf (c = "6th Black" Or c = "5th Black" Or c = "4th Black" Or c = "3rd Black" Or c = "2nd Black" Or c = "1st Black" Or c = "Jr. Black") Then 
    Set Target = ActiveWorkbook.Worksheets("BLACK") 
    Source.Rows(c.Row).Copy Target.Rows(j) 
    If (c = "6th Black" Or c = "5th Black" Or c = "4th Black" Or c = "3rd Black" Or c = "2nd Black" Or c = "1st Black" Or c = "Jr. Black") Then 
     Set Target = ActiveWorkbook.Worksheets("BLACK") 
     Source.Rows(c.Row).Copy Target.Rows(j) 
    ElseIf c = "1st Brown" Then 
     Set Target = ActiveWorkbook.Worksheets("1ST BROWN") 
     Source.Rows(c.Row).Copy Target.Rows(k) 
     k = k + 1 
    ElseIf c = "2nd Brown" Then 
     Set Target = ActiveWorkbook.Worksheets("2ND BROWN") 
     Source.Rows(c.Row).Copy Target.Rows(l) 
     l = l + 1 
    ElseIf c = "3rd Brown" Then 
     Set Target = ActiveWorkbook.Worksheets("3RD BROWN") 
     Source.Rows(c.Row).Copy Target.Rows(m) 
     m = m + 1 
    End If 

    j = j + 1 
    Next c 

Answer 1

うまくいけば、誰かがあなた

のために、より最適化されたバージョンをアップロードします...私はまさにそれに同意しないが、ここで

For Each c In Source.Range("b11:b110") 
    ' new condition to check cell e 
    if (c.offset(0, 3) <= 12 and Instr(1, c, "black", vbcomparemethod.vbtextcompare) <= 0) then 
     Set Target = ActiveWorkbook.Worksheets("KIDS NOTES") 
    elseIf (c = "6th Black" Or c = "5th Black" Or c = "4th Black" Or c = "3rd Black" Or c = "2nd Black" Or c = "1st Black" Or c = "Jr. Black") Then 
     Set Target = ActiveWorkbook.Worksheets("BLACK") 
     Source.Rows(c.Row).Copy Target.Rows(j) 
    ... 
enter code here