Формула Excel для ссылки на мастер-лист - PullRequest
0 голосов
/ 26 октября 2018

В настоящее время у меня есть мастер-лист Excel с именами около 20 различных продавцов, и создается новая строка с именем продавца в столбце А, когда они совершают продажу. Но теперь я хочу, чтобы эти данные были доступны продавцам, но я хочу, чтобы только они могли просматривать только их информацию, а не все. Итак, я собираюсь создать 20 различных отдельных файлов, по одному для каждого продавца.

Существует ли формула, которую я могу использовать для этих 20 различных электронных таблиц, чтобы обновлять для этих конкретных продавцов каждый раз, когда я обновляю основной лист?

1 Ответ

0 голосов
/ 27 октября 2018

Вы можете создавать рабочие книги из столбца (цикл от строки 1 до x) на основе уникальных значений.

Таким образом, для каждого уникального продавца в столбце А вы создаете новую рабочую книгу. Тогда вам нужно только использовать ваш текущий мастер-файл и делать все, что вы хотите в этом файле. Если вы хотите отправить лист продавцу, вы выполняете код, и Excel скопирует все строки, принадлежащие конкретному продавцу, и создаст для вас 20 отдельных листов, которые вы можете отправить.

Процесс:

У меня есть файл в папке, в котором хранятся все мои основные данные.

enter image description here

Основные данные выглядят следующим образом, и новые рабочие книги будут названы в честь столбца А. Рабочая книга будет создаваться только для уникальных имен.

enter image description here

После запуска макроса он создал следующие 5 новых рабочих книг.

enter image description here

Вот так выглядит Рабочая тетрадь "Анна - 10-27-18,14.24.47.xlsx":

enter image description here

Вот так выглядит Рабочая тетрадь "Belle- 10-27-18,14.24.47.xlsx":

enter image description here

Я использовал следующий код и только изменил его, чтобы сделать его динамическим для уникального столбца списка. Весь кредит Дж. Фоксу в SO

Код VBA:

Option Explicit

Sub ExportByName()
'Source and Credit: https://stackoverflow.com/questions/46368771/how-to-create-a-new-workbook-for-each-unique-value-in-a-column

Dim unique(1000) As String 'How many unique values we can store
Dim wb(1000) As Workbook
Dim ws As Worksheet
Dim x As Long, y As Long, ct As Long, uCol As Long, ColName As Long
Dim StaticDate As Date

On Error GoTo ErrHandler

Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual

'Your main worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")

'Column Where Unique Names are
ColName = 1

uCol = 12 'End column of data in MainFile


ct = 0

'get a unique list of users
For x = 2 To ws.Cells(ws.Rows.Count, ColName).End(xlUp).Row
    If CountIfArray(ActiveSheet.Cells(x, ColName), unique()) = 0 Then
        unique(ct) = ActiveSheet.Cells(x, ColName).Text
        ct = ct + 1
    End If
Next x

StaticDate = Now() 'This create the same timestamp for all the new workbooks

'loop through the unique list
For x = 0 To ws.Cells(ws.Rows.Count, ColName).End(xlUp).Row - 1

    If unique(x) <> "" Then
        'add workbook
        Set wb(x) = Workbooks.Add

        'copy header row
        ws.Range(ws.Cells(1, 1), ws.Cells(1, uCol)).Copy wb(x).Sheets(1).Cells(1, 1)

        'loop to find matching items in ws and copy over
        For y = 2 To ws.Cells(ws.Rows.Count, ColName).End(xlUp).Row
            If ws.Cells(y, ColName) = unique(x) Then

                'copy full formula over
                'ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1)

                'to copy and paste values
                ws.Range(ws.Cells(y, 1), ws.Cells(y, uCol)).Copy
                wb(x).Sheets(1).Cells(WorksheetFunction.CountA(wb(x).Sheets(1).Columns(uCol)) + 1, 1).PasteSpecial (xlPasteValues)

            End If
        Next y

        'autofit
        wb(x).Sheets(1).Columns.AutoFit

        'save when done
        wb(x).SaveAs ThisWorkbook.Path & "\" & unique(x) & " - " & Format(StaticDate, "mm-dd-yy, hh.mm.ss") & ".xlsx"
        wb(x).Close SaveChanges:=True

    Else
        'once reaching blank parts of the array, quit loop
        Exit For
    End If

Next x

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

ErrHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Public Function CountIfArray(lookup_value As String, lookup_array As Variant)
CountIfArray = Application.Count(Application.Match(lookup_value, lookup_array, 0))
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...