Разделить файл с макросами как отдельные файлы на основе значений столбца - PullRequest
Новая
       50

Разделить файл с макросами как отдельные файлы на основе значений столбца

1 голос
/ 27 апреля 2020

Представьте, что у меня есть файл, в котором уже есть макросы, которые применяются к данным. Я хочу разделить этот файл на несколько файлов на основе столбца региона таким образом, чтобы мне пришлось сохранить все функции макросов в этих разделенных файлах также из исходного файла. Пожалуйста, скажите мне, как это сделать в VBA. 

Sub SplitEachWorksheet()
    Dim FPath As String
    FPath = Application.ActiveWorkbook.Path
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each ws In ThisWorkbook.Sheets
        ws.Copy
        Application.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, 
    Filename:=FPath & "\" & ws.Name & ".xlsx"
    Application.ActiveWorkbook.Close False
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    End Sub

Но я не знаю, как разделить, сохранив функции макросов из исходного файла. подскажите пожалуйста как это сделать.

1 Ответ

0 голосов
/ 27 апреля 2020

Если вы хотите сделать это в VBA, я бы посоветовал вам написать код для:

  • Найти все значения из столбца Region
  • Для каждого региона:
    • Сделать полную копию исходного файла (включая макрос)
    • Удалить все строки, которые не принадлежат этому региону

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

Sub kopieer()
    Dim macro_wb As Workbook
    Dim macro_ws As Worksheet

    Dim orig_wb As Workbook
    Dim orig_ws As Worksheet
    Dim orig_range As Range
    Dim origpath As String
    Dim origname As String

    Dim region_wb As Workbook
    Dim region_ws As Worksheet
    Dim region As String
    Dim region_wb_name As String
    Dim region_row As Integer

    Application.ScreenUpdating = False

    origname = "D:\Oefen\test\Test_0.xlsm"

    ' Use this workbook to  find the regions
    Set macro_wb = ThisWorkbook
    Set macro_sheet = Sheet1
    macro_sheet.Cells.Clear

    Set orig_wb = Application.Workbooks.Open(Filename:=origname)
    origpath = orig_wb.Path
    ' Assuming the region is in first column of first Sheet
    Set orig_ws = orig_wb.Sheets(1)
    Set orig_range = orig_ws.Range([A2], [A2].End(xlDown))
    orig_range.Copy (Sheet1.[A1])
    orig_wb.Close

    ' Now we have all regions in column 1 of first sheet
    Sheet1.Range([A1], [A1].End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo

    ' loop throught the regions
    For row = 1 To Sheet1.[A1].End(xlDown).row
        region = Sheet1.Cells(row, 1)
        ' Make a full copy of the original file (including the macro's)
        region_wb_name = origpath + "\" + region + ".xlsm"
        FileCopy origname, region_wb_name
        ' Delete all rows which don't belong to that region
        Set region_wb = Application.Workbooks.Open(region_wb_name)
        Set region_ws = region_wb.Sheets(1)
        ' We are deleting rows, so we should start at the bottom
        For region_row = region_ws.[A2].End(xlDown).row To 2 Step -1
            If region_ws.Cells(region_row, 1).Value <> region Then
                region_ws.Rows(region_row).Delete
            End If
        Next region_row
        region_wb.Save
        region_wb.Close
    Next row

    Application.ScreenUpdating = True
End Sub
...