Блог

Я начал создавать скрипт, который поможет мне создавать рабочие листы на основе данных. У меня есть сводный лист с данными, отсортированными по имени клиента. Если у клиента есть только одна запись, то она должна быть на его собственном листе. Если у клиента несколько записей, все записи должны быть на 1 листе. Я запустил приведенный ниже код, но он по-прежнему помещает всех клиентов на их собственный лист.

Create_WB()

 Sub Create_WB()
    'duplicate worksheet and assign it to variable 'wb'
    Dim wb As Worksheet
    Sheets("Template").Copy After:=Sheets(Sheets.Count)
    Set wb = ActiveSheet

    'copy data over
    Worksheets("Summary").Range("A2").Copy wb.Range("A10")
    Worksheets("Summary").Range("B2").Copy wb.Range("A11")
    Worksheets("Summary").Range("C2").Copy wb.Range("C14")
    Worksheets("Summary").Range("D2").Copy wb.Range("A14")
    Worksheets("Summary").Range("E2").Copy wb.Range("E14")
    Worksheets("Summary").Range("F2").Copy wb.Range("G14")

    'delete row from summary
    Worksheets("Summary").Rows(2).Delete

End Sub
  

Check_CM()

 Sub Check_CM()

    'statement to check if next record has same c/m
    Do While Worksheets("Summary").Range("A2") <> ""
    '
    '
    If Worksheets("Summary").Range("A2") <> Worksheets("Summary").Range("A3") Then
         Call Create_WB


    Else

        Rows(14).Insert Shift:=xlDown
        Worksheets("Summary").Range("A2").Copy wb.Range("A10")
        Worksheets("Summary").Range("B2").Copy wb.Range("A11")
        Worksheets("Summary").Range("C2").Copy wb.Range("C14")
        Worksheets("Summary").Range("D2").Copy wb.Range("A14")
        Worksheets("Summary").Range("E2").Copy wb.Range("E14")
        Worksheets("Summary").Range("F2").Copy wb.Range("G14")
    '
    '
    '
    End If


    Loop

End Sub
  

Я хочу, чтобы все записи с одним и тем же клиентом были на одном листе, но у каждой записи есть свой собственный лист.

— Отказ от ответственности —

Вот некоторый код, который я написал, когда впервые начал изучать VBA.

Оглядываясь назад, я вижу много возможностей для улучшения. Однако у меня это сработало без проблем (хотя это могло быть из-за той позорной On Error Resume Next строки, которую я добавил). Поскольку это работает как есть, я оставлю тонкую настройку вам!

Это создаст новый лист (по одному для каждого уникального значения в Column A ), а затем переместит все связанные данные из каждого уникального значения на соответствующий лист.

Это предполагает

1. Исходные данные включены Sheet1
2. Ваши уникальные значения охватывают Column A
3. Ваш заголовок включен Row 1 , и ваши данные начинаются с Row 2

 Sub parse_data()

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 1
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row

' A1:Q5000 only needs to be modified if more than 4999 rows of data exists.

title = "A1:Q5000"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"

For i = 2 To lr
    On Error Resume Next
        If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear

For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) amp; ""
        If Not Evaluate("=ISREF('" amp; myarr(i) amp; "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) amp; ""
        Else
            Sheets(myarr(i) amp; "").Move after:=Worksheets(Worksheets.Count)
        End If
    ws.Range("A" amp; titlerow amp; ":A" amp; lr).EntireRow.Copy Sheets(myarr(i) amp; "").Range("A1")
    Sheets(myarr(i) amp; "").Columns.AutoFit
Next

ws.AutoFilterMode = False
ws.Activate

End Sub
  

Вот как я это исправил

 Sub Create()
'duplicate worksheet and assign it to variable 'wb'
Dim wb As Worksheet
Sheets("Template").Copy After:=Sheets(Sheets.Count)
Set wb = ActiveSheet
End Sub

Sub Copy()
'copy data over
Set wb = ActiveSheet
Worksheets("Summary").Range("A2").Copy wb.Range("A10")
Worksheets("Summary").Range("B2").Copy wb.Range("A11")
Worksheets("Summary").Range("C2").Copy wb.Range("C14")
Worksheets("Summary").Range("D2").Copy wb.Range("A14")
Worksheets("Summary").Range("E2").Copy wb.Range("E14")
Worksheets("Summary").Range("F2").Copy wb.Range("G14")

End Sub



Sub Del()
'delete row from summary
Worksheets("Summary").Rows(2).Delete






End Sub

Sub Update()


End Sub





Sub Check_CM()

Call Create


'statement to check if next record has same c/m

' while summary is not blank run pgm
Do While Worksheets("Summary").Range("A2") <> ""
'set active sheet
Set wb = ActiveSheet
'if c/m is not same as active sheet cm
If Worksheets("Summary").Range("A2") <> wb.Range("A10") Then
     Call Create
     Call Copy
     Call Del




Else
    ' Set active sheet
    Set wb = ActiveSheet

    'Shift Cells Down to add another row
    Rows(14).Insert Shift:=xlDown

    'copy data
    Worksheets("Summary").Range("A2").Copy wb.Range("A10")
    Worksheets("Summary").Range("B2").Copy wb.Range("A11")
    Worksheets("Summary").Range("C2").Copy wb.Range("C14")
    Worksheets("Summary").Range("D2").Copy wb.Range("A14")
    Worksheets("Summary").Range("E2").Copy wb.Range("E14")
    Worksheets("Summary").Range("F2").Copy wb.Range("G14")

    'delete data from summary sheet
    Call Del

'
'
'
End If


Loop





End Sub