CODEWITHSUNDEEP
excelvba
Abdio68
Abdio68

Reputation: 59

Copying rows from the sheets that starts as "INDEX"

I have a little problem with my VBA-code. I have multiple sheets merged from different Excel files. All those files have a sheet named "Index", so if I merge those sheets I get like Index, Index (1), Index (2)..

What I would like to do is that I want to copy all the values (even the blank cells) in row 2, from the sheets that starts with the name Index, because I merge other sheets from those files too, but I only want to copy the second row from the sheets that starts with Index.

This is my code so far (only the copying code)

Sub Samenvoegen()

 Dim J As Integer


On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Inlees tabblad"

' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
    Sheets(J).Activate ' make the sheet active
    Range("2:2").Select
    Range(Selection, Cells(Rows.Count, "2:2").End(xlUp)).Copy Range("2:2") ' select all cells in this sheets

    ' select all lines except title
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

    ' copy cells selected in the new sheet on last line
    Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
End Sub

And this is the code for merging:

This the code I use to open files and copy the locations:

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
 
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
 
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next
 
                wbkSrcBook.Close SaveChanges:=False
 
            Next
 
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Upvotes: 1

Views: 102

Answers (1)

VBasic2008
VBasic2008

Reputation: 54983

Copy Data from Worksheets Starting with Specified String

  • The result will start in row 2. If you want to start the result in row 1, you have to switch the lines like this:

    sws.Rows(2).Copy dCell
Set dCell = dCell.Offset(1)

Option Explicit

Sub Samenvoegen()

    Const dName As String = "Inlees tabblad"
    Const dFirst As String = "A1"
    Const sLeft As String = "Index"

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    On Error Resume Next
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    On Error GoTo 0
    
    If Not dws Is Nothing Then
       Application.DisplayAlerts = False
       dws.Delete
       Application.DisplayAlerts = True
    End If

    Set dws = wb.Worksheets.Add(Before:=wb.Sheets(1))
    dws.Name = dName
    Dim dCell As Range: Set dCell = dws.Range(dFirst)
    
    Dim sws As Worksheet
    
    For Each sws In wb.Worksheets
        If InStr(1, sws.Name, sLeft, vbTextCompare) = 1 Then
            Set dCell = dCell.Offset(1)
            sws.Rows(2).Copy dCell
        End If
    Next sws

End Sub

Upvotes: 1

Related Questions