Copying selected worksheets (value and formatting only) VBA

Benjeejump

New Member
Joined
Feb 8, 2019
Messages
6
Hi,

I have virtually no VBA knowledge, and am looking to copy the same selected sheets every week, and paste their values and formatting only into a new workbook. I think this can be done with a VBA macro?
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

KennyGreens

Board Regular
Joined
Aug 8, 2018
Messages
142
Hi, this is possible with a macro. Are there certain criteria for which sheets to copy from? Also, do you want to copy all the data from those certain sheets into the same new workbook or each sheet's data into separate new workbooks?
 

Benjeejump

New Member
Joined
Feb 8, 2019
Messages
6
Hi, this is possible with a macro. Are there certain criteria for which sheets to copy from? Also, do you want to copy all the data from those certain sheets into the same new workbook or each sheet's data into separate new workbooks?

The only criteria is the sheet name (which will always be the same). Yes from those selected sheets to the same new workbook.
 

Benjeejump

New Member
Joined
Feb 8, 2019
Messages
6

ADVERTISEMENT

Is there a list of the sheet names you wish to copy? Would be easier if that information was available.

H21 Sales Upload
H21 Rental Upload
Anchor Upload
Girlings Upload
McStone Upload
RHS Upload
RM Upload
 

KennyGreens

Board Regular
Joined
Aug 8, 2018
Messages
142
You can try something like this, not sure if it's the most efficient way but it should work. It assumes that you want the data pasted starting in cell A1.

Code:
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
  Dim i As Long
  ' default return value if value not found in array
  IsInArray = -1

  For i = LBound(arr) To UBound(arr)
    If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
      IsInArray = i
      Exit For
    End If
  Next i
End Function


Sub test()
Dim shnames As Variant
Dim sh As Worksheet
Dim oWB As Workbook
Dim nWB As Workbook
Dim x As Integer
Dim getname As String
shnames = Split("H21 Sales Upload,H21 Rental Upload,Anchor Upload,Girlings Upload,McStone Upload,RHS Upload,RM Upload", ",")
Set oWB = ThisWorkbook
Workbooks.Add
Set nWB = ActiveWorkbook
x = 1
For Each sh In oWB.Sheets
    If IsInArray(sh.Name, shnames) > -1 Then
        getname = sh.Name
        sh.Cells.Copy
            If x = 1 Then
                nWB.Sheets(x).Name = getname
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteValues
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteFormats
                x = x + 1
            Else
                nWB.Sheets.Add after:=nWB.Worksheets(Worksheets.Count)
                nWB.Sheets(x).Name = getname
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteValues
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteFormats
                x = x + 1
            End If
    End If
Next sh
Application.CutCopyMode = False
End Sub
 

Benjeejump

New Member
Joined
Feb 8, 2019
Messages
6
You can try something like this, not sure if it's the most efficient way but it should work. It assumes that you want the data pasted starting in cell A1.

Code:
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
  Dim i As Long
  ' default return value if value not found in array
  IsInArray = -1

  For i = LBound(arr) To UBound(arr)
    If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
      IsInArray = i
      Exit For
    End If
  Next i
End Function


Sub test()
Dim shnames As Variant
Dim sh As Worksheet
Dim oWB As Workbook
Dim nWB As Workbook
Dim x As Integer
Dim getname As String
shnames = Split("H21 Sales Upload,H21 Rental Upload,Anchor Upload,Girlings Upload,McStone Upload,RHS Upload,RM Upload", ",")
Set oWB = ThisWorkbook
Workbooks.Add
Set nWB = ActiveWorkbook
x = 1
For Each sh In oWB.Sheets
    If IsInArray(sh.Name, shnames) > -1 Then
        getname = sh.Name
        sh.Cells.Copy
            If x = 1 Then
                nWB.Sheets(x).Name = getname
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteValues
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteFormats
                x = x + 1
            Else
                nWB.Sheets.Add after:=nWB.Worksheets(Worksheets.Count)
                nWB.Sheets(x).Name = getname
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteValues
                nWB.Sheets(x).Range("A1").PasteSpecial xlPasteFormats
                x = x + 1
            End If
    End If
Next sh
Application.CutCopyMode = False
End Sub


That works a treat. Thank you so much!
 

Watch MrExcel Video

Forum statistics

Threads
1,129,550
Messages
5,636,962
Members
416,952
Latest member
prakashkumar

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top