KlausW
Active Member
- Joined
- Sep 9, 2020
- Messages
- 458
- Office Version
- 2016
- Platform
- Windows
Hi everyone.
I have a little challenge, I want a VBA code that can copy all data from column A2 to J2 and down after, only data. From 12 different sheets and past the data into a single sheet " Bestilling ", starting in cell K9 to R9 and down after. When running VBA code, it should not delete anything in sheets " Bestilling ".
Someone who can help
All help will be appreciated.
Best regards Klaus W
item ordering
I have a little challenge, I want a VBA code that can copy all data from column A2 to J2 and down after, only data. From 12 different sheets and past the data into a single sheet " Bestilling ", starting in cell K9 to R9 and down after. When running VBA code, it should not delete anything in sheets " Bestilling ".
Someone who can help
All help will be appreciated.
Best regards Klaus W
item ordering
VBA Code:
Sub Rektangelafrundedehjørner4_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
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
'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
