1

実際に私がやりたいことは、自動フィルタリングで次のデータがあります。

ここに画像の説明を入力

-> フィルタリングから選択された一意の名前ごとに新しいシートを作成したい。つまり、ジョンとアレックスが選択されている場合、2 つの新しいシートがジョン用に 1 つ、アレックス用に 2 つ作成され、それぞれに独自のデータが表示されます (Name + No + R）。次回マスターシートが更新された場合、マクロを実行するとニュースデータが追加されます。次のコードを使用していますが、100% は機能しません。

Sub mycar()
   x = 2
   Do While Cells(x, 1) <> ""
   If Cells(x, 1) = "John" Then
   Worksheets("Sheet1").Rows(x).Copy
   Worksheets("Sheet2").Activate
   eRow = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
   ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(eRow)
   End If
   Worksheets("Sheet1").Activate
   x = x + 1
   Loop
End Sub

-> ここでは、引用符で囲まれた単一のデータのみをコピーします。

-> このコードを 2 回目に実行すると、同じデータに新しいデータが追加されます。

この間違いを避けるのを手伝ってください。

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

4

4 に答える 4

2

説明したように、手順で配列にフィルター パラメーターを設定する別の可能性があります。コードは次のようになります。

Sub Solution()

Dim shData As Worksheet
    Set shData = Sheets("Arkusz1")    'or other reference to data sheet
Dim shNew As Worksheet
    shData.Activate
'get unique values based on Excel features
Range("a1").AutoFilter

Dim myArr As Variant
    myArr = Array("John", "max")

Range("a1").AutoFilter

Dim i As Long
For i = 0 To UBound(myArr)
    shData.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i), _
        Operator:=xlAnd
On Error Resume Next
    Sheets(myArr(i)).Range("A1").CurrentRegion.ClearContents

If Err.Number = 0 Then
    Range("A1").CurrentRegion.Copy Sheets(myArr(i)).Range("A1")
Else
    Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
    shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
    shNew.Name = myArr(i)
    Err.Clear
End If

Next i
'removing filter in master sheet
shData.Range("a1").AutoFilter

End Sub
于 2013-04-04T18:42:00.633 に答える
0

Worksheets("Sheet1").Rows(x).Copyで代用Worksheets("Sheet1").Rows(x).EntireRow.Copy

情報を追加する前に、宛先ワークシートをクリアします。

于 2013-04-03T19:30:28.067 に答える
0

見出し ## 以下のコードは、要件に応じたものです。要件に基づいて変更します。

Private Sub Worksheet_Calculate()
  Dim x As Integer
  Dim rnge As Integer
  x = Range(Selection, Selection.End(xlDown)).Count
  rnge = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count

  If Range("E1").Value > rnge Then
   Range("A1").Select
   Range(Selection, Selection.End(xlToRight)).Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.Copy
   Sheets(2).Select
   ActiveSheet.Paste
  End If
End Sub
于 2013-04-07T04:37:45.370 に答える
0

私はよく似たような運動をしています。したがって、コード内にいくつかのコメントを付けて、可能な限りの解決策を提供します。列 A のすべての一意の値に対して機能し、(存在しない場合は) フィルター パラメーターに等しい適切な名前のシートを作成します。

Sub Solution()
Dim shData As Worksheet
    Set shData = Sheets("Arkusz1")    'or other reference to data sheet
Dim shNew As Worksheet

'get unique values based on Excel features
'i guess some will not like it but I do :)
Range("a1").AutoFilter
Range("A1").CurrentRegion.Columns(1).Copy Range("ww1")
Range("ww1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
'be sure that range where you copy (like ww1) is empty range around 

Dim myArr As Variant
    myArr = Range(Range("ww2"), Range("ww2").End(xlDown))
Range("ww1").CurrentRegion.ClearContents     'some cleaning
Range("a1").AutoFilter '

Dim i As Long
For i = 1 To UBound(myArr, 1)
    ActiveSheet.Range("$A$1").AutoFilter Field:=1, Criteria1:=myArr(i, 1), _
        Operator:=xlAnd
On Error Resume Next
    'this is for two reason- to check if appropriate sheet exists, if so to clean top area
    'if you need to append you would comment this line
    Sheets(myArr(i, 1)).Range("A1").CurrentRegion.ClearContents

If Err.Number = 0 Then
    'if you need to append only you would need to set range-to-copy a bit different
    Range("A1").CurrentRegion.Copy Sheets(myArr(i, 1)).Range("A1")
Else
    Set shNew = Sheets.Add(After:=Sheets(Sheets.Count))
    shData.Range("A1").CurrentRegion.Copy shNew.Range("A1")
    shNew.Name = myArr(i, 1)
    Err.Clear
End If

Next i

End Sub

これは要件を完全に満たすことはできませんでしたが、それに応じて改善するための完全なソリューションになる可能性があります。

于 2013-04-03T20:08:11.747 に答える