CODEWITHSUNDEEP
excelvba
user15169505
user15169505

Reputation:

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

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.

https://i.sstatic.net/OV3af.png

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

Upvotes: 1

Views: 249

Answers (1)

Wizhi
Wizhi

Reputation: 6549

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:

enter image description here

If we have this data in "Summary Dash"

enter image description here

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

enter image description here

Upvotes: 1

Related Questions