Copying selected worksheets (value and formatting only) VBA

[Benjeejump]

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?

 

[KennyGreens]

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]

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.

 

[KennyGreens]

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

All on the same sheet in the new workbook or separate sheets as well?

 

[Benjeejump]

All on the same sheet in the new workbook or separate sheets as well?

Seperate sheets as well

 

[KennyGreens]

Seperate sheets as well

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

 

[Benjeejump]

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]

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.

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]

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.

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!

 

[KennyGreens]

No problem at all, happy I can help.