VBA-code shall not delete

KlausW

KlausW

Active Member
Joined
Sep 9, 2020
Messages
396
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code: 
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
 
Sort by date Sort by votes
Well with the code in post 10 you have put a: ' in front of every line of code so nothing will happen.

a ' means do not run this line of code
 
Upvote 0

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
To try to cosoludate all sheets into one sheet and keep all the formulas working as normal is:
This is beyond my knowledgebase.
I will continue to monitor this thread to see what I can learn.
 
Upvote 0
After the code you deleted / commented out add this line:
VBA Code: 
Set DstSht = ActiveWorkbook.Sheets("Consolidate_Data")
 
Upvote 0
I am assuming that you have the functions that the coded uses but was not included in what you sent.

The only way I can get the code "to do nothing" after the changes is for there to be no sheet called Consolidate_Data
Does this sheet exist in your workbook ?
Note: There is an underscore between the 2 words.

Below is the code with the functions and it seems to consolidate the data to the Sheet Consolidate_Data.
The output starts at K2.

The original source looks to be from here but there are variable errors in the functions that had to be correced
Excel VBA Append data from multiple Worksheets into a single Sheet

VBA Code: 
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

    ' XXX Add back set statement
    Set DstSht = ActiveWorkbook.Sheets("Consolidate_Data")
    
    '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

'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)

    'Dim lastCol As Long
    Dim lCol As Long
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol

End Function

'In this example we are finding the last Row of specified Sheet
'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)

    'Dim lastRow As Long
    Dim lRow As Long
    
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow

End Function
 
Upvote 0
KlausW said:
Hi
I found this VBA code on the internet
Click to expand...
Hi, the better when creating a thread is to well enough elaborate your need with some accurate attachment rather than finding such a bad code …​
 
Upvote 0
Alex Blakenburg said:
I am assuming that you have the functions that the coded uses but was not included in what you sent.

The only way I can get the code "to do nothing" after the changes is for there to be no sheet called Consolidate_Data
Does this sheet exist in your workbook ?
Note: There is an underscore between the 2 words.

Below is the code with the functions and it seems to consolidate the data to the Sheet Consolidate_Data.
The output starts at K2.

The original source looks to be from here but there are variable errors in the functions that had to be correced
Excel VBA Append data from multiple Worksheets into a single Sheet

VBA Code: 
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

    ' XXX Add back set statement
    Set DstSht = ActiveWorkbook.Sheets("Consolidate_Data")
   
    '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

'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(ByVal Sht As Worksheet)

    'Dim lastCol As Long
    Dim lCol As Long
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol

End Function

'In this example we are finding the last Row of specified Sheet
'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(ByVal Sht As Worksheet)

    'Dim lastRow As Long
    Dim lRow As Long
   
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow

End Function
Click to expand...
Yes it is and I have just find det funktion code
VBA Code: 
'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(Sht As Worksheet)

    Dim LastRow As Long
    LastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow

End Function
 
Upvote 0
KlausW said:
Yes it is and I have just find det funktion code
VBA Code: 
'In this example we are finding the last Row of specified Sheet
Function fn_LastRow(Sht As Worksheet)

    Dim LastRow As Long
    LastRow = Sht.Cells.SpecialCells(xlLastCell).Row
    lRow = Sht.Cells.SpecialCells(xlLastCell).Row
    Do While Application.CountA(Sht.Rows(lRow)) = 0 And lRow <> 1
        lRow = lRow - 1
    Loop
    fn_LastRow = lRow

End Function
Click to expand...
VBA Code: 
'In this example we are finding the last column of specified Sheet
Function fn_LastColumn(Sht As Worksheet)

    Dim lastCol As Long
    lastCol = Sht.Cells.SpecialCells(xlLastCell).Column
    lCol = Sht.Cells.SpecialCells(xlLastCell).Column
    Do While Application.CountA(Sht.Columns(lCol)) = 0 And lCol <> 1
        lCol = lCol - 1
    Loop
    fn_LastColumn = lCol

End Function
 
Upvote 0
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.
 
Upvote 0

Yes the original code is cumbersome, terrible ! The author seems to not well know the Excel / VBA basics, using useless functions …​
 
Upvote 0
You must log in or register to reply here.

Similar threads

V
  • Solved
Newbie to VBA - output from a names selection on worksheets, ignoring others
Replies
1
Views
346
VBAPower
V
KlausW
  • Solved
Copy from multi sheets to one sheets
2
Replies
14
Views
1K
KlausW
KlausW
S
  • Question
Merge data into a table, filter and remove any blanks then remove the table range and re run without deleting the tab and recreating it
Replies
0
Views
480
StillUnderstanding
S
A
  • Question
VBA - Loop to consolidate lists from multiple workbooks into a consolidated table
Replies
0
Views
339
anthonygws
A
R
  • Question
Adding Email Signature to current VBA Code
Replies
3
Views
225
John_w
J

Forum statistics

Threads
1,215,993
Messages
6,128,175
Members
449,429
Latest member
ianharper68

Share this page

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
Back
Top