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