VBA - Copy data between workbooks. Add column with filename and don't copy empty rows

[pagrav]

Hi, can someone please help, I am new to VBA.
I have 22 workbooks, they all contain data in the same format (two sheets pr workbook).
I want to consolidate data from the 22 workbooks into one master workbook.

Old posts in Mr.Excel gave me help here and this works fine using this VBA :

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    'Folder that contains data
    Const strPath As String = "\\nash\PAG003\Dokumenter\Masterfiler\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            'Copy data from all workbooks in the datafolder
            .Sheets("Kostsentre").Range("A2:F" & Range("A" & Rows.Count).End(xlUp).Row + 1).Copy wkbDest.Sheets("Koststeder").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Sheets("Brukertilganger").Range("A3:J" & Range("A" & Rows.Count).End(xlUp).Row + 1).Copy wkbDest.Sheets("Brukere").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

But, now I want the VBA to do the following :
1. Don't copy empty rows from the 22 source files. Both worksheets in the 22 source-files can contain empty rows. If there is data in column A, the row should be copied.
2. Add a new column into master-file that gives the filename the data was copied from. I only need this data inn masterworksheet "Brukere" - so would prefer that the column was in column K

Would appreciate help

 

[mumps]

Try this macro. (UNTESTED)

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, desWS1 As Worksheet, desWS2 As Worksheet, lRow As Long
    Set wkbDest = ThisWorkbook
    Set desWS1 = wkbDest.Sheets("Kostsentre")
    Set desWS2 = wkbDest.Sheets("Brukere")
    'Folder that contains data
    Const strPath As String = "\\nash\PAG003\Dokumenter\Masterfiler\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            'Copy data from all workbooks in the datafolder
            .Sheets("Kostsentre").Range("A2:F" & .Sheets("Kostsentre").Range("A" & Rows.Count).End(xlUp).Row + 1).Copy desWS1.Cells(desWS1.Rows.Count, "A").End(xlUp).Offset(1)
            lRow = .Sheets("Brukertilganger").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("Brukertilganger").Range("A3:J" & lRow + 1).Copy desWS2.Cells(desWS2.Rows.Count, "A").End(xlUp).Offset(1)
            desWS2.Cells(desWS2.Rows.Count, "K").End(xlUp).Offset(1).Resize(lRow - 2) = wkbSource.Name
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    desWS1.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    desWS2.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

 

[pagrav]

Try this macro. (UNTESTED)

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbDest As Workbook, wkbSource As Workbook, desWS1 As Worksheet, desWS2 As Worksheet, lRow As Long
    Set wkbDest = ThisWorkbook
    Set desWS1 = wkbDest.Sheets("Kostsentre")
    Set desWS2 = wkbDest.Sheets("Brukere")
    'Folder that contains data
    Const strPath As String = "\\nash\PAG003\Dokumenter\Masterfiler\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            'Copy data from all workbooks in the datafolder
            .Sheets("Kostsentre").Range("A2:F" & .Sheets("Kostsentre").Range("A" & Rows.Count).End(xlUp).Row + 1).Copy desWS1.Cells(desWS1.Rows.Count, "A").End(xlUp).Offset(1)
            lRow = .Sheets("Brukertilganger").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("Brukertilganger").Range("A3:J" & lRow + 1).Copy desWS2.Cells(desWS2.Rows.Count, "A").End(xlUp).Offset(1)
            desWS2.Cells(desWS2.Rows.Count, "K").End(xlUp).Offset(1).Resize(lRow - 2) = wkbSource.Name
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    desWS1.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    desWS2.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

This code does excactly what I wanted it to do - Thanks for the quick respons and very good help mumps

 

[mumps]

You are very welcome.