VBA-code shall not delete

[KlausW]

Hi
I found this VBA code on the internet, it does what I need.
The only thing I do not want it to do is that when I run the code, it deletes the entire sheet, it must not delete anything.

All help will be appreciated

Best regards Klaus W.

Sub Rektangelafrundedehjørner1_Klik()

'Procedure to Consolidate all sheets in a workbook

On Error GoTo IfError

'1. Variables declaration

Dim Sht As Worksheet, DstSht As Worksheet

Dim LstRow As Long, LstCol As Long, DstRow As Long

Dim i As Integer, EnRange As String

Dim SrcRng As Range

'2. Disable Screen Updating - stop screen flickering

' And Disable Events to avoid inturupted dialogs / popups

With Application

.ScreenUpdating = False

.EnableEvents = False

End With

'3. Delete the Consolidate_Data WorkSheet if it exists

Application.DisplayAlerts = False

On Error Resume Next

ActiveWorkbook.Sheets("Consolidate_Data").Delete

Application.DisplayAlerts = True

'4. Add a new WorkSheet and name as 'Consolidate_Data'

With ActiveWorkbook

Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))

DstSht.Name = "Consolidate_Data"

End With

'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet

For Each Sht In ActiveWorkbook.Worksheets

If Sht.Name <> DstSht.Name Then

'5.1: Find the last row on the 'Consolidate_Data' sheet

DstRow = fn_LastRow(DstSht)

'5.2: Find Input data range

LstRow = fn_LastRow(Sht)

LstCol = fn_LastColumn(Sht)

EnRange = Sht.Cells(LstRow, LstCol).Address

Set SrcRng = Sht.Range("a2:" & EnRange)

'5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet

If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then

MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."

GoTo IfError

End If

'5.4: Copy data to the 'consolidated_data' WorkSheet

SrcRng.Copy Destination:=DstSht.Range("k" & DstRow + 1)

End If

Next

'DstSht.Range("A1") = "You can place the headeing in the first row"

IfError:

'6. Enable Screen Updating and Events

With Application

.ScreenUpdating = True

.EnableEvents = True

End With

End Sub

 

[Alex Blakenburg]

​

Yes the original code is cumbersome, terrible ! The author seems to not well know the Excel / VBA basics, using useless functions …​

It actually crashes, I have sent them an email notifying them, it will be interesting to see if they fix it.

 

[Marc L]

​

Too many useless things within, must be recreated from a blank sheet ! The reason why I wrote in this thread post #16 …​

 

[KlausW]

Don't use the code you have it has an error in it. (Inconsistent use of variable names)

I have provided you a full set of working code please use that.

Hi Alex Blakenburg it does work, the only thing is that the code inserts the values in the wrong places. I would like it to put the dignitaries into K2 instead of K12656 as it does now. The error that comes is that the values are inserted in column K after the last formula in column A. Hope it makes sense. KW

 

[Alex Blakenburg]

I would like it to put the dignitaries into K2 instead of K12656 as it does now.

My understanding is that this is dependent on the order in which the sheets are processed.
If you want a particular sheet to be consolidated first, then give me the sheet name and I will modify the code.
If you want all the sheets added in a specific order I will need all the sheet names in order.

The error that comes is that the values are inserted in column K after the last formula in column A.

What error ?
If the code errors out, what is the error message, and when click on debug which line in the code is highlighted?

 

[KlausW]

My understanding is that this is dependent on the order in which the sheets are processed.
If you want a particular sheet to be consolidated first, then give me the sheet name and I will modify the code.
If you want all the sheets added in a specific order I will need all the sheet names in order.

What error ?
If the code errors out, what is the error message, and when click on debug which line in the code is highlighted?

Hi again Alex Blakenburg
The code works well enough, the only thing I would like was the inserted value in K9 and down after. As it is now, the value is inserted according to the formulas in column A. See pic 1 is as it looks now, pic 2 is as it should look. Hope it makes sense. KW

 

[Alex Blakenburg]

It is quite late here in Australia, please also send me a picture of the sheet that data in column k is coming from.
I am guessing it doesn't start in A1.
I will then look tomorrow.

 

[KlausW]

It is quite late here in Australia, please also send me a picture of the sheet that data in column k is coming from.
I am guessing it doesn't start in A1.
I will then look tomorrow.

Thanks have a good night from Denmark KW

 

[Alex Blakenburg]

the only thing I would like was the inserted value in K9 and down after.

Try this.
Replace the current section 5 with the below.
The changes are:
• Added this line before the For Each Sht

DstRow = 9          ' XXX Klaus wanted the first copy at row 9

• Moved getting the value for DstRow that was inside the loop from the beginning to the end so that is uses the 9 above for the first pass.

section 5 replacement
From '5 to Next

   '5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
    DstRow = 9          ' XXX Klaus wanted the first copy at row 9
    
    For Each Sht In ActiveWorkbook.Worksheets
        If Sht.Name <> DstSht.Name Then
            '5.2: Find Input data range
            LstRow = fn_LastRow(Sht)
            LstCol = fn_LastColumn(Sht)
            EnRange = Sht.Cells(LstRow, LstCol).Address
            Set SrcRng = Sht.Range("a2:" & EnRange)
            '5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
            If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
                MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
                GoTo IfError
            
            End If
            
            '5.4: Copy data to the 'consolidated_data' WorkSheet
            SrcRng.Copy Destination:=DstSht.Range("k" & DstRow + 1)
            
            '5.1: Find the last row on the 'Consolidate_Data' sheet for the next copy
            'Moved to end of loop not required for 1st pass
            DstRow = fn_LastRow(DstSht)
        End If
    
    Next

 

[KlausW]

Try this.
Replace the current section 5 with the below.
The changes are:
• Added this line before the For Each Sht

DstRow = 9          ' XXX Klaus wanted the first copy at row 9

• Moved getting the value for DstRow that was inside the loop from the beginning to the end so that is uses the 9 above for the first pass.

section 5 replacement
From '5 to Next

   '5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
    DstRow = 9          ' XXX Klaus wanted the first copy at row 9
   
    For Each Sht In ActiveWorkbook.Worksheets
        If Sht.Name <> DstSht.Name Then
            '5.2: Find Input data range
            LstRow = fn_LastRow(Sht)
            LstCol = fn_LastColumn(Sht)
            EnRange = Sht.Cells(LstRow, LstCol).Address
            Set SrcRng = Sht.Range("a2:" & EnRange)
            '5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
            If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
                MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
                GoTo IfError
           
            End If
           
            '5.4: Copy data to the 'consolidated_data' WorkSheet
            SrcRng.Copy Destination:=DstSht.Range("k" & DstRow + 1)
           
            '5.1: Find the last row on the 'Consolidate_Data' sheet for the next copy
            'Moved to end of loop not required for 1st pass
            DstRow = fn_LastRow(DstSht)
        End If
   
    Next

Hi Alex Blakenburg it works as it should, just what I wanted, after what I have tested, should be on course, so it will be first this weekend. Thanks for the help I will be right back if it's okay. Many thanks and day, many greetings from Denmark Klaus

 

[Alex Blakenburg]

No problem, we will be here if you have questions. Thanks for the update.
It is always nice to know what time zone people are operating in, thank you for sharing.