L oop Через диапазоны в другой книге на основе значения ячейки

Question

Я использовал код ниже, чтобы l oop через диапазон. Теперь мне нужно изменить sourceRange на диапазон в рабочей тетради Analysis v1.

В сводном листе этой рабочей книги в ячейках B2 и B3 есть имена заголовков столбцов на другом листе этой рабочей книги под названием Data. Заголовки таблицы данных находятся в строке 2.

Мне бы хотелось, чтобы макрос нашел заголовки столбцов B2 и B3, а затем l oop через каждый столбец, но это выходит за рамки моих текущих навыков VBA.

Может кто-нибудь помочь?

Спасибо

Опция Явная

Публикация c Sub Process ()

Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range

' Customize this settings
Set targetWorkbook = Workbooks("Analysis v1.xlsm")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("Q3:Q5")

Application.ScreenUpdating = False

' Loop through each cell in source range
For Each cell In sourceRange.Cells
    ' Validate that cell has a value
    If cell.Value <> vbNullString Then

        summarySheet.Range("F3").Value = cell.Value
        ' Execute procedure to create new sheet
        CreateNewSheet
    End If
Next cell

Application.ScreenUpdating = True

End Sub

Answer 1

Привет, пожалуйста, проверьте следующие коды для вашей ссылки. Просто покажите метод добавления / сохранения книги.

Sub aa()
Dim targetWorkbook As Workbook
Dim summarySheet As Worksheet
Dim sourceRange As Range
Dim cell As Range

' Customize this settings
'Set targetWorkbook = Workbooks("Analysis v1.xlsm")
Set summarySheet = ThisWorkbook.Worksheets("Summary")
Set sourceRange = summarySheet.Range("Q3:Q5")

Application.ScreenUpdating = False

'not very clear for your logic ******
 'Loop through each cell in source range
For Each cell In sourceRange.Cells
    ' Validate that cell has a value
    If cell.Value <> vbNullString Then

        summarySheet.Range("F3").Value = cell.Value
        ' Execute procedure to create new sheet
        End If
Next cell
' *************************
'Here is the demo of how to copy and save to a new workbook.
Set targetWorkbook = Workbooks.Add
Dim fName As String
fName = "Analysis v1.xlsm"

targetWorkbook.Sheets(1).Range("A1") = summarySheet.Range("F3").Value
Application.DisplayAlerts = False
On Error Resume Next
targetWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & fName, FileFormat:=52
targetWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub