Динамический массив для хранения имени листа - PullRequest
Новая
       59

Динамический массив для хранения имени листа

0 голосов
/ 11 ноября 2019

Хе Я пытаюсь сделать следующее:

  • Слить лист из другой рабочей книги
  • , используя данные на листе слияния для выполнения расчета и получения результата
  • результат будет вставлен на их лист
  • после того, как вычисление выполнено, создайте вкладку сводки, которая объединит все данные на этой вкладке
  • сохраните вкладку сводки и вкладку объединения других в новую рабочую книгу

Моя проблема заключается в следующем: я хочу заменить twb.Sheets(Array("Summary", "M 100P 1", "M 100P 2", "M 100P 5", "M 100P 6", "M 100P 12", "M 100P 13", "M 100P 15", "M 100P 16")).Copy на динамический массив, поскольку имя листа слияния совпадает с их исходным файлом, и это может измениться. Я не могу использовать условие «Мне нравится», поэтому япопробуйте использовать код ниже, но он возвращает myArray пусто 

Option Base 1
Sub SheetsArr()
    Dim myArray() As String
    Dim myCount As Integer, NumSheets As Integer

    NumSheets = ThisWorkbook.Worksheets.Count - 4
    ReDim myArray(1 To NumSheets)

    For myCount = 4 To NumSheets
        myArray(myCount) = ActiveWorkbook.Sheets(myCount).Name
    Next myCount
End Sub

Получена ошибка

Ошибка несоответствия типов

и выделите эту строку кодана главном модуле If UBound(myArray) > 0 Then Worksheets(myArray).Copy

Вот мой основной код модуля: 

Private Sub OpenWorkBook_Click()
    'for merge sheet from other workbooks
    Dim wbk, twb As Workbook
    Dim sPath, sFile, sName, mySheet As String
    Dim cpt, wsCountMerge, wsCount, WsIndex As Integer

    sPath = "C:\Users\mazman\Desktop\Hilmi\data Summary\" 'Your folder path
    sFile = Dir(sPath & "*.xls*")

    Set twb = ThisWorkbook
    Application.ScreenUpdating = 0

    Countmergesheet = 0
    Do While sFile <> "" 'merge raw data sheet process start here
        Set wbk = Workbooks.Open(sPath & sFile)

        With wbk
            sName = Split(Split(.Name, "_")(6), ".")(0) 'initialize sheet name based on the file name
            .Sheets(3).Copy after:=twb.Sheets(twb.Sheets.Count) 'copy each sheets(3) from the data summary and paste after visible sheet on this workbook
            .Close 0
        End With

        With twb
        .ActiveSheet.Name = sName 'rename sheet
        .ActiveSheet.Range("A1:R1").RowHeight = 45
        .ActiveSheet.Range("A1:R1").WrapText = True
        .ActiveSheet.Range("A1:R1").Interior.ColorIndex = 15
        End With
        sFile = Dir()

        If twb.ActiveSheet.Name = sName Then
            Countmergesheet = Countmergesheet + 1 'count how many sheet is merge
        End If
    Loop

    wsCount = twb.Sheets.Count
    wsCountMerge = wsCount - Countmergesheet 'to get the 1st merge sheet index
    WsIndex = wsCount - 1 'to get the last sheet index

    '################# This section copy data from origin sheet #################
    '###### to formula sheet then paste result to its origin sheet ##############
    For i = wsCountMerge To WsIndex
    With twb
    .Sheets(i).Range("A2:R3063").Copy
    .Worksheets("STEP 1").Range("A3").PasteSpecial xlPasteValues

    .Sheets(i).Cells.Clear
    .Sheets(3).Range("A9:O27").Copy
    .Sheets(i).Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
    .Sheets(i).Range("A1").PasteSpecial xlPasteValues
    .Sheets(i).Range("A1:O19").ColumnWidth = 10.8

    '################# This section copy data to summary sheet ################
    .Sheets(i).Range("A2:O18").Copy
    .Worksheets("Summary").Select
    ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveSheet.Paste

    For j = 1 To 17
    ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1).Select
    ActiveCell.Value = .Sheets(i).Name
    ActiveCell.BorderAround , xlThin
    Next j

    .Worksheets("STEP 1").Range("A3:R6034").Clear
    .Worksheets("STEP 1").Activate: .Sheets("STEP 1").Cells(1).Select
    .Sheets(i).Activate: .Sheets(i).Cells(1).Select
    .Sheets("Summary").Activate: .Sheets("Summary").Cells(1).Select
    '######                   End of section                   ################

    End With
    Next i

    Call InsertFormulas
    Call SheetsArr

    If UBound(myArray) > 0 Then Sheets(myArray).Copy
    ActiveWorkbook.SaveAs Filename:=sPath & "Summary Report" & ".xlsx"
End Sub

1 Ответ

1 голос
/ 11 ноября 2019

Ваш ReDim заставляет myArray начинать с 1. Но счетчик цикла, myCount, начинается с 4.

Я исправляю счетчик цикла, myCount, начинать с1, как показано ниже. 

Sub SheetsArr()
    Dim myArray() As Variant
    Dim myCount As Long, NumSheets As Long

    NumSheets = ThisWorkbook.Worksheets.Count - 4
    ReDim myArray(1 To NumSheets)

    For myCount = 1 To NumSheets
        myArray(myCount) = ActiveWorkbook.Sheets(myCount).Name
    Next myCount
End Sub

новый ответ

Согласно вашему main module коду, я думаю, вы могли бы

Шаг 1.

переписать свой SheetArr() подчиняется функции, как показано ниже. 

Option Base 1
Function SheetsArr() As Variant
    Dim myArray() As Variant  'from String to Variant
    Dim myCount As Long, NumSheets As Long  'from Integer to Long

    NumSheets = ThisWorkbook.Worksheets.Count - 4
    ReDim myArray(1 To NumSheets)

    For myCount = 1 To NumSheets
        myArray(myCount) = ThisWorkbook.Worksheets(myCount).Name 'from ActiveWorkbook.Sheets to ThisWorkbook.Worksheets as the definition of NumSheets
    Next myCount
    SheetsArr = myArray
End Function

шаг 2.

В main module необходимо добавить 

Dim myArray As Variant

переписать 

Call SheetsArr

до 

myArray = SheetsArr()
...