Convert Multiple Excel Sheet Ranges as Picture to New Excel Workbook as worksheets

Question

I have been trying to paste the Excel Sheet ranges as Picture to the New Workbook as worksheets (Each Range as different worksheet)

The code is take the Status of Col"E" If it is = Include then its corresponding sheets ranges will be pasted as picture to New Workbook.

If Col"E" <> Include then code should skip this. There are 3 Includes in below picture so the code will paste picture as ranges of that Sheets which are = Include in there separate sheets of new workbook.

any help will be appreciated.

Sub SelectSheets_Ranges()
  Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
  
  Set sh = ActiveSheet
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
  
  ReDim arr(lastR - 1)
  For i = 2 To lastR
        If sh.Range("E" & i).value = "Include" Then
            arr(k) = sh.Range("C" & i).value & "|" & sh.Range("D" & i).value: k = k + 1
        End If
  Next i
  ReDim Preserve arr(k - 1)
  For i = 0 To UBound(arr)
        arrSplit = Split(arr(i), "|")
        Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
  
            
NewBook = Workbooks.Add

      Next
    End Sub

The problem is how to add further codes to make it complete. Earlier i asked same questions and i strive to change PDF to Excel but it seems like impossible. that's why posted here. — user15169505

Wizhi Wizhi · Accepted Answer · 2021-06-09T19:58:12

I would take each value from the range and store them in an array separately. Then use the "Sheet Name" as main loop value and check/use the other column values as I loop through each rows.

Workbook and "main" sheet name need to be adjusted to your workbook name and worksheet.

Something like this:

Option Explicit

Sub copy_and_paste_as_picture()

Dim wb As Workbook, wb_new As Workbook
Dim sheetMain As Worksheet
Dim lastR, i, k As Long
Dim arr As Variant


Set wb = ThisWorkbook 'Set name of the master workbook
Set sheetMain = wb.Worksheets("Sheet1") 'Set name of the main sheet

lastR = sheetMain.Range("C" & sheetMain.Rows.Count).End(xlUp).Row 'Find last row

arr = sheetMain.Range(sheetMain.Cells(6, "C"), sheetMain.Cells(lastR, "E")).Value 'Import range to array
Set wb_new = Workbooks.Add 'Add a new workbook

For i = LBound(arr, 1) To UBound(arr, 1) 'Loop through array
    If arr(i, 3) = "Include" Then 'If Status is include then
        wb_new.Sheets.Add(After:=Sheets(Sheets.Count)).Name = arr(i, 1) 'Add new worksheet to the new workbook with the selected name
        With wb.Worksheets(arr(i, 1)).Range(arr(i, 2)) 'Select range to copy
            .CopyPicture xlScreen, xlBitmap
            wb_new.Sheets(arr(i, 1)).Range("A1").PasteSpecial 'Paste as picture
        End With
    End If
Next i

End Sub

I assume my data looks like this and all the relevant sheets exists (i.e. sheets where "included" exists). Workbook named to Book12.xlsm:

If we have this data in "Summary Dash"

the worksheet will be copied to the new workbook (Book6.xlsx) as a picture (with same sheet name).

Convert Multiple Excel Sheet Ranges as Picture to New Excel Workbook as worksheets

1 Answers