Copy a range from one sheets to a new one.

[KlausW]

Hi

I have a challenge I would like some help with. I use this VBA code to copy sheets with to a new sheet. With the name from Cell F2. This works really well, now I would like it to be from cells A8 to cells H8 and until there is no text in column A-H. The columns contain formulas.
Anyone who can help?
Any help we would be appreciated
Best Regards

Klaus W

Private Sub MM1()



Application.ScreenUpdating = False

'----------/Døber variable/--------------'

Dim CopyWb As Workbook, PasteWB As Workbook

Dim CopyWS As Worksheet, PasteWS As Worksheet

Dim NameCell As Range

Dim Name As String

'----------/Tildeler variable indhold/--------------'

Set CopyWb = ThisWorkbook

Set CopyWS = CopyWb.Sheets("Bestilling")

Set NameCell = CopyWS.Range("f2")

Set PasteWB = Workbooks.Add

Set PasteWS = PasteWB.Sheets(1)

Name = NameCell.Value

'----------/Navngiver ark 1/--------------'

PasteWS.Name = CopyWS.Name

'----------/Tager en kopi af cellerne i "bestilling"/--------------'

CopyWS.Cells.Copy

'----------/formaterer og overfører data til det nye ark/--------------'

PasteWS.Cells.PasteSpecial xlPasteValues

PasteWS.Cells.PasteSpecial xlPasteFormats

'PasteWS.Rows("9").Select

'ActiveWindow.FreezePanes = True

PasteWS.Range("A1").Select

Application.CutCopyMode = False

'----------//--------------'

Application.ScreenUpdating = True



Application.Dialogs(xlDialogSaveAs).Show Name, 51



’Hide_Gridlines



End Sub

 

[Sam_D_Ben]

Please change to "A8" in Set NameCell = CopyWS.Range("F2")

_thankx

 

[KlausW]

it doesn't work, by changing this it is only where Excel has to find names. KW

 

[kevin9999]

Hi Klaus, try the following onn a copy of your workbook.

Option Explicit
Sub KlausW()
    Dim PasteWB As Workbook
    Dim CopyWS As Worksheet, PasteWS As Worksheet
    Set CopyWS = ThisWorkbook.Worksheets("Bestilling")
    Dim NameCell As String, r As Range
    NameCell = CopyWS.Range("F2").Value2
    
    Set PasteWS = Workbooks.Add.Worksheets(1)
    PasteWS.Name = NameCell
    
    Set r = CopyWS.Range("A8:H" & CopyWS.Range("A:H").Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    With r
        .Copy
        With PasteWS.Cells(1, 1)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        Application.CutCopyMode = False
    End With
End Sub

 

[KlausW]

Hi kevin9999 I will return tomorrow.
Thanks
KW

 

[KlausW]

Hi kevin9999
The VBA code copies the desired field well enough. But I'm missing two things. It doesn't name the new file after cell G2, that's where the file name is. Sheets name is in cell G3. Another thing is that it would be great if Excel adjusted the columns to fit the text.
Klaus W

 

[kevin9999]

It doesn't name the new file after cell G2, that's where the file name is. Sheets name is in cell G3.

That's because this is the first time you've mentioned cells G2 & G3 ?! Previously, you said the sheet name was in cell F2.
See if this variation works for you.

Option Explicit
Sub KlausW_V2()
    Dim PasteWB As Workbook
    Dim CopyWS As Worksheet, PasteWS As Worksheet
    Set CopyWS = ThisWorkbook.Worksheets("Bestilling")
    Dim WsName As String, WbName As String, r As Range
    WbName = CopyWS.Range("G2").Value2
    WsName = CopyWS.Range("G3").Value2
    
    Set PasteWS = Workbooks.Add.Worksheets(1)
    PasteWS.Name = WsName
    
    Set r = CopyWS.Range("A8:H" & CopyWS.Range("A:H").Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    With r
        .Copy
        With PasteWS.Cells(1, 1)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        Application.CutCopyMode = False
    End With
    
    PasteWS.UsedRange.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & WbName & ".xlsm", FileFormat:=52
End Sub

 

[KlausW]

That's because this is the first time you've mentioned cells G2 & G3 ?! Previously, you said the sheet name was in cell F2.
See if this variation works for you.

Option Explicit
Sub KlausW_V2()
    Dim PasteWB As Workbook
    Dim CopyWS As Worksheet, PasteWS As Worksheet
    Set CopyWS = ThisWorkbook.Worksheets("Bestilling")
    Dim WsName As String, WbName As String, r As Range
    WbName = CopyWS.Range("G2").Value2
    WsName = CopyWS.Range("G3").Value2
  
    Set PasteWS = Workbooks.Add.Worksheets(1)
    PasteWS.Name = WsName
  
    Set r = CopyWS.Range("A8:H" & CopyWS.Range("A:H").Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
    With r
        .Copy
        With PasteWS.Cells(1, 1)
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
        End With
        Application.CutCopyMode = False
    End With
  
    PasteWS.UsedRange.EntireColumn.AutoFit
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & WbName & ".xlsm", FileFormat:=52
End Sub

 

[KlausW]

Hi kevin9999, spot on. Just as it should be.
Greetings and good weekend Klaus W

 

[kevin9999]

Hi kevin9999, spot on. Just as it should be.
Greetings and good weekend Klaus W

Happy to help Klaus, and thanks for the feedback