Copy from multi sheets to one sheets

[KlausW]

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

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

 

[Trebor76]

Hi KW,

Here's one way:

Option Explicit
Sub Consol()

    Dim ws As Worksheet, wsConsol As Worksheet
    Dim lngLastRow As Long, lngPasteRow As Long
    
    Application.ScreenUpdating = False
    
    Set wsConsol = ThisWorkbook.Sheets("Bestilling")
    lngPasteRow = 9 'Starting Row number for the consolidation of the sheet data in 'wsConsol'.
    
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> wsConsol.Name Then
            On Error Resume Next
                lngLastRow = ws.Range("A:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lngLastRow >= 2 Then
                ws.Range("A2:I" & lngLastRow).Copy Destination:=wsConsol.Range("K" & lngPasteRow)
                lngPasteRow = wsConsol.Range("K:S").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
        End If
    Next ws
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[My Aswer Is This]

Looks like you now have a answer that works for you.

 

[KlausW]

Looks like you now have a answer that works for you.

Yes I have

 

[My Aswer Is This]

Yes I have

Glad we were able to help you.
Come back here to Mr. Excel next time you need additional assistance.

 

[KlausW]

Hi KW,

Here's one way:

Option Explicit
Sub Consol()

    Dim ws As Worksheet, wsConsol As Worksheet
    Dim lngLastRow As Long, lngPasteRow As Long
   
    Application.ScreenUpdating = False
   
    Set wsConsol = ThisWorkbook.Sheets("Bestilling")
    lngPasteRow = 9 'Starting Row number for the consolidation of the sheet data in 'wsConsol'.
   
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> wsConsol.Name Then
            On Error Resume Next
                lngLastRow = ws.Range("A:I").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lngLastRow >= 2 Then
                ws.Range("A2:I" & lngLastRow).Copy Destination:=wsConsol.Range("K" & lngPasteRow)
                lngPasteRow = wsConsol.Range("K:S").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
            End If
        End If
    Next ws
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Hello Robert

Thank you very much, it's just as it should be. I just have a question, can it be made so that what is consolidated in sheet "Bestilling" K to S, text and the edge will be in a different color? Eg. white.

Once again thank you.

Best regards

Klaus W