Copy and Paste Data to VBA created sheets

Question

Working in an Excel document that I didn't design.

I am trying to automate raw data into an report type spreadsheet.

In short. I have code that does everything I need it to as far as formatting, moving columns, calculations, lookups and etc. I even have it creating new sheets based off of data that is in a certain column. The goal is for there to be sheets for every executive that has their data on it and only their data. While maintaining a sheet that has all data on it. So I need to copy and past only their data to their Sheet. I am really close....I think.

Currently the code creates the correct sheets, it even names them correctly. However, it moves the data incorrectly. For example I expect there to 15 records on sheet 2, but there is 10 I expect and 17 random others. Also, you can run the macro twice and get different results on the sheets.

I have exhausted two other people, and several search's today. I have no idea how to fix it. There is a lot of formatting code above this code. I am a basic user of VBA. I can do a good bit of things with it, but this code came from a colleague who has more experience, but then he couldn't figure out why it did what its doing. I'm running out of time. So I really would appreciate any help.

The code is as below.

'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

My apologies, I know I'm a messy code writer. If you couldn't tell, I'm mostly self taught.

Thanks in advance.

I don't see why you are looping through the data, when you always paste to A2 in Sheets(old_val) ? — KyloRen

Unknown Unknown · Accepted Answer · 2016-07-15T00:24:08

If you are not filtering the data you don't need to use SpecialCells(xlCellTypeVisible). I use a function getWorkSheet to return a reference to the new worksheet. If the SheetName already exists the function will return that worksheet otherwise it will create a new worksheet rename it SheetName and return the new worksheet.

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

Copy and Paste Data to VBA created sheets

1 Answers