Мне нужен код Excel VBA для импорта значения ячейки и имени листа из многих книг - PullRequest
0 голосов
/ 25 апреля 2019

плохо знакомый с этим, Ищите код для выбора ячейки "B39" и имени листа из нескольких рабочих книг в выбранной папке. Ниже уже используется код, который выбирает имя листа из нескольких рабочих книг, просто нужно добавить ячейку значение «B39» на выходы. Спасибо за вашу помощь

Новый формат рабочей книги Колонка "А" = название листа Столбец "B" = значение ячейки "B39" (текст)

    Sub LoopAllExcelFilesInFolder()

Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog

'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  ActiveWorkbook.CheckCompatibility = False
  Application.AskToUpdateLinks = False
  Application.DisplayAlerts = False

'Retrieve Target Folder Path From User
  Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

    With FldrPicker
      .Title = "Select A Target Folder"
      .AllowMultiSelect = False
        If .Show <> -1 Then GoTo NextCode
        myPath = .SelectedItems(1) & "\"
    End With

'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings

'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"

'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)

'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)

    'Ensure Workbook has opened before moving on to next line of code
      DoEvents

    'If DataEntry is the active ws, then change to the next worksheet
    If ActiveSheet.Name = "DataEntry" Then
    ActiveSheet.Next.Activate
    End If

      'Insert a Column of Worksheet names
    Columns(1).Insert
      For i = 1 To Sheets.Count
      Cells(i, 1) = Sheets(i).Name
      Next i

      'Selects then Copy/Paste into SCD list
        If Cells(2, 1).Value = "" Then
        Cells(1, 1).Select
        Selection.Copy
        Else:
        Range(Range("A1"), Range("A1").End(xlDown)).Select
        Selection.Copy
        End If

        Windows("SCD List.xlsm").Activate

        'Paste into SCD List
        If Cells(1, 1).Value = "" Then
            Cells(1, 1).Select
        Else:
        Range("A1").End(xlDown).Offset(1, 0).Select
        End If
        ActiveSheet.Paste

    'Closes Workbook without copying
      wb.Close SaveChanges:=False

    'Ensure Workbook has closed before moving on to next line of code
      DoEvents

    'Get next file name
      myFile = Dir
  Loop

'Message Box when tasks are completed
  MsgBox "Task Complete!"

ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

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