Macro to copy paste range of all worksheets except one (and future worksheets)

[jbesclapez]

Hello MrExcel,

I have a worksheet called GLOBAL
I have other worksheets and more are to come.
I would like to find a way to copy paste range A1:H500 of all workheets to GLOBAL, all after eachother and then delete empty rows.
In the column "I" of GLOBAL I want to know the Worksheets it is coming from.

Hope i am clear enough. Dont hesitate to ask anything.

Thanks for your precious help

 

[wideboydixon]

Re: Macro to copy paste range of all worskeets except one (and future worksheets)

Q: Are there blank lines on the other sheets in between data or are the blank lines at the end of the data (i.e. can I find the last row on the other sheets and assume that there are no blank lines included).

Q: What happens if I run the macro again? Should I remove the previous data and start again or should I add it to the bottom of the GLOBAL sheet?

WBD

 

[jbesclapez]

Re: Macro to copy paste range of all worskeets except one (and future worksheets)

Q: Are there blank lines on the other sheets in between data or are the blank lines at the end of the data (i.e. can I find the last row on the other sheets and assume that there are no blank lines included).

Q: What happens if I run the macro again? Should I remove the previous data and start again or should I add it to the bottom of the GLOBAL sheet?

WBD

First of all, I would like to thank you wideboydixon for having a look at it ! Please find below my answer.

Q1: Well Spoted. I forgot to inform you about that. Please use all lines untill row 1000. Then copy as values into GLOBAL and only in GLOBAL delete the blank rows.

Q2: Then macro should delete all content of column A:G everything in Global

Hope it is clearer now.

 

[wideboydixon]

Re: Macro to copy paste range of all worskeets except one (and future worksheets)

I assume you mean A:I as that's the range that will be populated.

Public Sub PasteAllDataToGlobal()

Dim globalSheet As Worksheet
Dim thisSheet As Worksheet
Dim lastRow As Long
Dim nextRow As Long
Dim thisRow As Long

' Turn off screen updating for speed
Application.ScreenUpdating = False

' Clear the contents of the GLOBAL sheet
Set globalSheet = Worksheets("GLOBAL")
globalSheet.Range("A:I").ClearContents

' Next row to paste data
nextRow = 1

' Process all worksheets
For Each thisSheet In Worksheets
    ' Ignore the GLOBAL sheet
    If thisSheet.Name <> "GLOBAL" Then
        ' This would be ideal
        ' lastRow = thisSheet.Cells(thisSheet.Rows.Count, 1).End(xlUp).Row
        
        ' This, however, is the instruction
        lastRow = 1000
        
        ' Copy the cells
        thisSheet.Range(thisSheet.Cells(1, 1), thisSheet.Cells(lastRow, 8)).Copy Destination:=globalSheet.Cells(nextRow, 1)
        
        ' Remove blank lines (*sigh*)
        thisRow = nextRow + lastRow - 1
        Do While thisRow >= nextRow
            If WorksheetFunction.CountA(globalSheet.Cells(thisRow, 1).EntireRow) = 0 Then
                globalSheet.Cells(thisRow, 1).EntireRow.Delete xlShiftUp
                lastRow = lastRow - 1
            End If
            thisRow = thisRow - 1
        Loop
        
        ' Fill in the sheet name
        globalSheet.Range(globalSheet.Cells(nextRow, 9), globalSheet.Cells(nextRow + lastRow - 1, 9)).Value = thisSheet.Name
        
        ' Move to the next available row
        nextRow = nextRow + lastRow
    End If
Next thisSheet

' Turn on screen updating
Application.ScreenUpdating = True

End Sub

WBD

 

[jbesclapez]

Re: Macro to copy paste range of all worskeets except one (and future worksheets)

I assume you mean A:I as that's the range that will be populated.

Public Sub PasteAllDataToGlobal()

Dim globalSheet As Worksheet
Dim thisSheet As Worksheet
Dim lastRow As Long
Dim nextRow As Long
Dim thisRow As Long

' Turn off screen updating for speed
Application.ScreenUpdating = False

' Clear the contents of the GLOBAL sheet
Set globalSheet = Worksheets("GLOBAL")
globalSheet.Range("A:I").ClearContents

' Next row to paste data
nextRow = 1

' Process all worksheets
For Each thisSheet In Worksheets
    ' Ignore the GLOBAL sheet
    If thisSheet.Name <> "GLOBAL" Then
        ' This would be ideal
        ' lastRow = thisSheet.Cells(thisSheet.Rows.Count, 1).End(xlUp).Row
        
        ' This, however, is the instruction
        lastRow = 1000
        
        ' Copy the cells
        thisSheet.Range(thisSheet.Cells(1, 1), thisSheet.Cells(lastRow, 8)).Copy Destination:=globalSheet.Cells(nextRow, 1)
        
        ' Remove blank lines (*sigh*)
        thisRow = nextRow + lastRow - 1
        Do While thisRow >= nextRow
            If WorksheetFunction.CountA(globalSheet.Cells(thisRow, 1).EntireRow) = 0 Then
                globalSheet.Cells(thisRow, 1).EntireRow.Delete xlShiftUp
                lastRow = lastRow - 1
            End If
            thisRow = thisRow - 1
        Loop
        
        ' Fill in the sheet name
        globalSheet.Range(globalSheet.Cells(nextRow, 9), globalSheet.Cells(nextRow + lastRow - 1, 9)).Value = thisSheet.Name
        
        ' Move to the next available row
        nextRow = nextRow + lastRow
    End If
Next thisSheet

' Turn on screen updating
Application.ScreenUpdating = True

End Sub

WBD

Great, This does the job. Thank you!!

I also did read the code and I envy you so much... my VBA is not great (I can't do loops).

I tried to uncomment the line below
' This would be ideal
lastRow = thisSheet.Cells(thisSheet.Rows.Count, 1).End(xlUp).Row
And then I commented this : 'lastRow = 1000
But then then the code still goes to 1000 rows.... and because the name of the sheet in column I is copied to 1000, I cannot use my macro that deletes empty rows... What a puzzle!!

 

[wideboydixon]

Re: Macro to copy paste range of all worskeets except one (and future worksheets)

If you're happy copying rows 1-1000 then I'd leave the original code as is.

WBD

 

[jbesclapez]

Re: Macro to copy paste range of all worskeets except one (and future worksheets)

OK... I add to think about all this for a bit (let it rest) and I think what you did will do the job. The problem was on my side.
So it is only a quick post to tell you thank you Dixon and have a nice week