VBA l oop через строки, затем столбцы - PullRequest
1 голос
/ 11 марта 2020

Я ОЧЕНЬ новичок в VBA, поэтому будьте осторожны ...

Я пытаюсь автоматизировать создание новой вкладки в нескольких книгах. Каждую неделю вручную создается новая вкладка для предстоящих выходных.

Я могу получить код для поиска по столбцу, чтобы найти выходные, которые необходимо создать, но затем я бы хотел перейти к следующий столбец и сделайте то же самое. На одной вкладке рабочей книги «Создатель» у меня есть выходные дни (Даты), на другой - список отдельных рабочих книг (Книги), для которых потребуется создать новую вкладку. Список отдельных рабочих книг захватывается другим сценарием, а затем печатается на вкладках «Даты» (в строке 2, начиная с C2) и «Книги» (в столбце A, начиная со строки 2). Я приложил пример рабочей книги «создатель», которую я использую. Вновь созданная вкладка должна быть переименована на правильные выходные. Пример вкладки "Даты"

Пример вкладки "Книги"

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

Sub createNewTab()
    Dim wB As Workbook
    Dim wS As Worksheet
    Dim bK As Worksheet
    Dim r As Long
    Dim i As Long
    Dim c As Long
    Dim fPath As String
    Dim lastRow As Long
    Dim lastDate As Long
    Dim bDate As String
    Dim eDate As String
    Dim created As Long
    Dim newBook As Workbook
    Dim lDate As String
    Dim nDate As String
    Dim nBDate As String
    Dim nEDate As String
    Dim allSheets As Long


Set wB = Workbooks("Example Sheet Creator")
Set wS = wB.Sheets("Dates")
Set bK = wB.Sheets("Books")
lastRow = bK.Cells(Rows.Count, "A").End(xlUp).Row
lastDate = wS.Cells(Rows.Count, "C").End(xlUp).Row
allSheets = wS.Cells(2, Columns.Count).End(xlToLeft).Column


For c = 3 To allSheets
 Do While c <= allSheets
    For r = 2 To lastRow

        If r <= lastRow And wS.Cells(2, c).Value = bK.Cells(r, 1).Value Then

            For i = 3 To lastDate

                While i <= lastDate And wS.Cells(i, 3).Text = "n"

                    bDate = Format(wS.Cells(i - 1, 1).Value, "mmm dd")
                    eDate = Format(wS.Cells(i - 1, 2).Value, "mmm dd")
                    nBDate = Format(wS.Cells(i, 1).Value, "mmm dd")
                    nEDate = Format(wS.Cells(i, 2).Value, "mmm dd")
                    fPath = bK.Cells(r, 2).Value
                    Application.ScreenUpdating = False
                    lDate = bDate & " - " & eDate
                    nDate = nBDate & " - " & nEDate

                    Set newBook = Workbooks.Open(fPath)


                    newBook.Sheets("Mar 14 - Mar 15").Copy After:=Worksheets(Sheets.Count)
                    'On Error Resume Next
                    ActiveSheet.Name = nDate


                    wS.Cells(i, 3).Value = "Y"

                    i = i + 1
                Wend

            Next i

            r = r + 1

        End If

    Next r

c = c + 1
Loop
Next c

End Sub

В идеале, она будет соответствовать названию в строке 2 на датах списку в столбце А на книгах. В будущем название / порядок отдельных рабочих книг, перечисленных на вкладке «Книги», может измениться.

1 Ответ

0 голосов
/ 13 марта 2020

Это использует 2 цикла. Отсканируйте лист с книгами, и для каждой книги отсканируйте листы с датами. Он проверяет, что вкладка не существует перед ее созданием.

Sub createNewTab()

    Const COPY_SHEET = "Mar 14 - Mar 15"

    Dim wb As Workbook, ws As Worksheet, wsDates As Worksheet, wsBooks As Worksheet
    Dim wbTarget As Workbook, wsTarget As Worksheet
    Dim rng As Range, rngDates As Range
    Dim iBookRow As Long, iLastBook As Long
    Dim iDateRow As Long, iLastDate As Long
    Dim iNameCol As Long, sYesNo As String, bOK As Boolean

    Set wb = ThisWorkbook
    Set wsBooks = wb.Sheets("Books")
    Set wsDates = wb.Sheets("Dates")

    iLastBook = wsBooks.Cells(Rows.count, 1).End(xlUp).Row
    iLastDate = wsDates.Cells(Rows.count, 1).End(xlUp).Row
    Set rngDates = wsDates.Rows(2)
    Debug.Print iLastBook, iLastDate, rngDates.Address

    Dim sName As String, sFilename As String, sTab As String
    Dim count As Long, countWb As Long, n As Integer

    ' scan down the books sheet
    For iBookRow = 2 To iLastBook

        sName = wsBooks.Cells(iBookRow, 1)
        sFilename = wsBooks.Cells(iBookRow, 2)
        'Debug.Print sName, sFilename

        ' find column for this name on Dates
        Set rng = rngDates.Find(sName)
        If rng Is Nothing Then
           MsgBox "Could not find " & sName & " on Dates sheet", vbExclamation
           GoTo Skip
        End If
        iNameCol = rng.Column

        ' open target workbook
        Set wbTarget = Workbooks.Open(sFilename)
        countWb = countWb + 1

        ' scan down dates for sName
        For iDateRow = 3 To iLastDate
            sYesNo = wsDates.Cells(iDateRow, iNameCol)
            sTab = Format(wsDates.Cells(iDateRow, 1), "mmm dd") & " - " & _
                   Format(wsDates.Cells(iDateRow, 2), "mmm dd")

            ' is create needed
            If sYesNo <> "Y" Then

                ' check sheet doesn't exist
                bOK = True
                For Each ws In wbTarget.Sheets
                   If ws.Name = sTab Then bOK = False
                Next

                 ' create sheet
                If bOK Then
                    With wbTarget
                        n = .Sheets.count
                        .Sheets(COPY_SHEET).Copy After:=.Sheets(n)
                        .Sheets(n + 1).Name = sTab
                    End With
                    wsDates.Cells(iDateRow, iNameCol) = "Y"
                    count = count + 1
                Else
                    MsgBox sTab & " already exists in " & wbTarget.Name, vbExclamation
                    wsDates.Cells(iDateRow, iNameCol) = "Y"
                End If

            End If

            'Debug.Print sName, iDateRow, sYesNo, sTab
        Next
        wbTarget.Close True
Skip:
   Next

   MsgBox count & " sheets created in " & countWb & " workbooks", vbInformation

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...