データをコピーしてVBAで作成したシートに貼り付けます

Question

デザインしていないExcelドキュメントで作業しています。

生データをレポートタイプのスプレッドシートに自動化しようとしています。

要するに、私はフォーマット、移動、計算、ルックアップなどを移動するために必要なすべてを行うコードを持っています。特定の列にあるデータに基づいて新しいシートを作成することさえあります。目標は、そこにデータがあるすべての幹部のためのシートとそのデータだけであることです。すべてのデータを保持しているシートを維持しながら。だから私は彼らのシートに自分のデータだけをコピーして過ぎる必要があります。私は本当に近いです....私は思う。

現在のところ、コードは正しいシートを作成し、正しく名前を付けることさえできます。ただし、データを誤って移動します。例えば、私は2枚目に15枚のレコードがあると思っていますが、10枚は期待しており、17枚はランダムです。また、マクロを2回実行して、シート上で異なる結果を得ることもできます。

私はもう2人の人を疲れさせてしまい、今日はいくつかの検索が行われています。私はそれをどのように修正するのか分かりません。このコードの上には多くの書式設定コードがあります。私はVBAの基本ユーザーです。私はそれで良いことをすることができますが、このコードはより多くの経験を持つ同僚から来ましたが、なぜ彼はそれが何をしたのか理解できませんでした。私は時間がなくなっています。だから私は本当に助けに感謝します。

コードは以下のとおりです。

'create new sheets 
On Error GoTo ErrHandle 
Dim vl As String 
wb = ActiveWorkbook.Name 
cnt = Application.WorksheetFunction.CountA(ActiveWorkbook.Sheets("Sheet1").Range("S:S")) 
For i = 2 To cnt 
    vl = Workbooks(wb).Sheets("Sheet1").Cells(i, 19).Value 
    WS_Count = Workbooks(wb).Worksheets.Count 
    a = 0 
    For j = 1 To WS_Count 
     If vl = Workbooks(wb).Worksheets(j).Name Then 
      a = 1 
      Exit For 
     End If 
    Next 
    If a = 0 Then 
     Sheets.Add After:=ActiveSheet 
     ActiveSheet.Name = vl 
     Sheets("Sheet1").Activate 
     Range("A1:V1").Select 
     Selection.SpecialCells(xlCellTypeVisible).Select 
     Selection.Copy 
     Sheets(vl).Activate 
     Range("A1").Select 
     ActiveSheet.Paste 
    End If 
Next 

Sheets("Sheet1").Activate 
j = 2 

old_val = Cells(2, 19).Value 

For i = 3 To cnt 
    new_val = Cells(i, 19).Value 

    If old_val <> new_val Then 
     Range("A" & j & ":V" & i).Select 
     Selection.SpecialCells(xlCellTypeVisible).Select 
     Selection.Copy 
     Sheets(old_val).Activate 
     Range("A2").Select 
     ActiveSheet.Paste 

     Sheets("Sheet1").Activate 

     old_val = Cells(i + 1, 19).Value 
     j = i + 1 
    End If 
Next 

On Error GoTo ErrHandle 

Worksheets("0").Activate 
ActiveSheet.Name = "External Companies" 
Worksheets("Sheet1").Activate 
ActiveSheet.Name = "All Data" 


Worksheets("All Data").Activate 
Range("A1").Select 

Workbooks("PERSONAL.xlsb").Close SaveChanges:=False 
ActiveWorkbook.SaveAs ("Indirect_AVID_Approval") 
Exit Sub 

ErrHandle: 
MsgBox "Row: " & i & " Value =:" & vl 
End Sub 

私は厄介なコードライターです。あなたが言うことができなければ、私は主に独学です。

ありがとうございます。

Answer 1

データをフィルタリングしていない場合は、SpecialCells(xlCellTypeVisible)を使用する必要はありません。私は関数getWorkSheetを使用して、新しいワークシートへの参照を返します。 SheetNameが既に存在する場合、関数はそのワークシートを返します。そうでない場合、新しいワークシートを作成し、そのシート名を変更して新しいワークシートを返します。

Sub ProcessWorksheet() 
    Dim lFirstRow As Long 

    Dim SheetName As String 
    Dim ws As Worksheet 

    With Sheets("Sheet1") 
     cnt = WorksheetFunction.CountA(.Range("S:S")) 

     For i = 2 To cnt 
      If .Cells(i, 19).Value <> SheetName Or i = cnt Then 
       If lFirstRow > 0 Then 
        Set ws = getWorkSheet(SheetName) 
        .Range("A1:V1").Copy ws.Range("A1") 
        .Range("A" & lFirstRow & ":V" & i - 1).SpecialCells(xlCellTypeVisible).Copy Destination:=ws.Range("A2") 
       End If 
       SheetName = .Cells(i, 19).Value 
       lFirstRow = i 
      End If 

     Next 
    End With 

     Worksheets("0").Activate 
     ActiveSheet.Name = "External Companies" 
     Worksheets("Sheet1").Activate 
     ActiveSheet.Name = "All Data" 


     Worksheets("All Data").Activate 
     Range("A1").Select 

     Workbooks("PERSONAL.xlsb").Close SaveChanges:=False 
     ActiveWorkbook.SaveAs ("Indirect_AVID_Approval") 

End Sub 


Function getWorkSheet(SheetName As String) As Worksheet 
    Dim ws As Worksheet 
    On Error Resume Next 
    Set ws = Worksheets(SheetName) 

    If ws Is Nothing Then 
     Set ws = Worksheets.Add(after:=ActiveSheet) 
     ws.Name = SheetName 
    End If 

    On Error GoTo 0 
    Set getWorkSheet = ws 
End Function