Looping issue in VBA

[dsnaveen]

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Monthly_1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range("B4:o30")
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Iam generate VBA code to loop thru multiple excel files, copy data from 4 sheets into one sheet, each sheet having specific range to select and consolidate all into one sheet.
The looping is working in this, the issue is output is coming as formula not values.
how to Just copy only the values and ignore all formats & formulas.
Can you please help.

 

[mumps]

Replace this line of code:

xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)

with these two lines of code:

xRg.Copy
xSheet.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

 

[dsnaveen]

Replace this line of code:

xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)

with these two lines of code:

xRg.Copy
xSheet.Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

Thank you, its working...

 

[mumps]

You are very welcome.

 

[dsnaveen]

Sub ConsolidateDataFromMultipleFiles()
    Dim SourceFolder As String
    Dim FileExt As String
    Dim FileName As String
    Dim wbSource As Workbook
    Dim wsSource1 As Worksheet, wsSource2 As Worksheet, wsSource3 As Worksheet, wsSource4 As Worksheet
    Dim wsDest As Worksheet
    Dim myPath As String

    ' Set the source folder path and file extension
    SourceFolder = "C:\TEST_1\"
    FileExt = "*.xlsx" ' Change to your file extension

    ' Set the destination worksheet
    Set wsDest = ThisWorkbook.Sheets("ConsolidatedData") ' Change to your destination sheet name

    ' Clear existing data in the destination sheet
    wsDest.Cells.Clear

    ' Loop through each file in the folder
    FileName = Dir(SourceFolder & FileExt)
    Do While FileName <> ""
        Set wbSource = Workbooks.Open(SourceFolder & FileName, ReadOnly:=True)

        ' Set references to source worksheets
        Set wsSource1 = wbSource.Sheets("Monthly_1") ' Change to your sheet names
        Set wsSource2 = wbSource.Sheets("Monthly_2")
        Set wsSource3 = wbSource.Sheets("Monthly_3")
        Set wsSource4 = wbSource.Sheets("Monthly_4")

        ' Copy data from source sheets to destination sheet
        wsSource1.UsedRange.Copy
        wsSource1.Range("B4:O30").Copy
        wsDest.Range("A" & wsDest.Range("A" & Rows.Count).End(xlUp).Row + 2).PasteSpecial xlPasteValues
        

        wsSource2.UsedRange.Copy
        wsSource2.Range("B4:O30").Copy
        wsDest.Range("A" & wsDest.Range("A" & Rows.Count).End(xlUp).Row + 2).PasteSpecial xlPasteValues
        FileNameWOExt = Left(FileName, InStr(FileName, ".") - 1)

        wsSource3.UsedRange.Copy
        wsSource3.Range("B4:o29").Copy
        wsDest.Range("A" & wsDest.Range("A" & Rows.Count).End(xlUp).Row + 2).PasteSpecial xlPasteValues
        FileNameWOExt = Left(FileName, InStr(FileName, ".") - 1)

        wsSource4.UsedRange.Copy
        wsSource4.Range("B4:o25").Copy
        wsDest.Range("A" & wsDest.Range("A" & Rows.Count).End(xlUp).Row + 2).PasteSpecial xlPasteValues
        FileNameWOExt = Left(FileName, InStr(FileName, ".") - 1)
        
        Application.CutCopyMode = False

        wbSource.Close SaveChanges:=False
        FileName = Dir
    Loop
End Sub

Hi Guys,
This script Generate VBA code to loop thru multiple excel files, copy data from 4 sheets into one sheet, each sheet having specific range to select and consolidate all into one sheet. copies only the values.
2 doubt i have
1. How to get the FileName in VBA?
-- i tried FileNameWOExt = Left(FileName, InStr(FileName, ".") - 1)
2. how to give Monthly_1, Monthly_2.. hardcode in sheet.
I need to get the sheet name in the rows.
Any suggestion please..

 

[dsnaveen]

Sub ConsolidateDataFromMultipleFilesWithNames()
    Dim SourceFolder As String
    Dim FileExt As String
    Dim FileName As String
    Dim wbSource As Workbook
    Dim wsSource1 As Worksheet, wsSource2 As Worksheet, wsSource3 As Worksheet, wsSource4 As Worksheet
    Dim wsDest As Worksheet
    Dim DestRow As Long

    ' Set the source folder path and file extension
    SourceFolder = "C:\TEST_1\"
    FileExt = "*.xlsx" ' Change to your file extension

    ' Set the destination worksheet
    Set wsDest = ThisWorkbook.Sheets("ConsolidatedData") ' Change to your destination sheet name

    ' Clear existing data in the destination sheet
    wsDest.Cells.Clear

    ' Initialize destination row
    DestRow = 2

    ' Loop through each file in the folder
    FileName = Dir(SourceFolder & FileExt)
    Do While FileName <> ""
        Set wbSource = Workbooks.Open(SourceFolder & FileName, ReadOnly:=True)

        ' Set references to source worksheets
        Set wsSource1 = wbSource.Sheets("Monthly1") ' Change to your sheet names
        Set wsSource2 = wbSource.Sheets("Monthly2")
        Set wsSource3 = wbSource.Sheets("Monthly3")
        Set wsSource4 = wbSource.Sheets("Monthly4")

        ' Copy data from source sheets to destination sheet
        Dim LastRowSrc1 As Long
        Dim LastRowSrc2 As Long
        Dim LastRowSrc3 As Long
        Dim LastRowSrc4 As Long
        
        LastRowSrc1 = wsSource1.Cells(wsSource1.Rows.Count, "B").End(xlUp).Row
        LastRowSrc2 = wsSource2.Cells(wsSource2.Rows.Count, "B").End(xlUp).Row
        LastRowSrc3 = wsSource3.Cells(wsSource3.Rows.Count, "B").End(xlUp).Row
        LastRowSrc4 = wsSource4.Cells(wsSource4.Rows.Count, "B").End(xlUp).Row
        
        wsSource1.Range("B4:O30").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc1 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc1 - 4).Value = wsSource1.Name
        DestRow = DestRow + LastRowSrc1 - 3

        wsSource2.Range("B4:O30").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc2 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc2 - 4).Value = wsSource2.Name
        DestRow = DestRow + LastRowSrc2 - 3

        wsSource3.Range("B4:O29").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc3 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc3 - 4).Value = wsSource3.Name
        DestRow = DestRow + LastRowSrc3 - 3

        wsSource4.Range("B4:O25").Copy
        wsDest.Range("C" & DestRow).PasteSpecial xlPasteValues
        wsDest.Range("A" & DestRow, "A" & DestRow + LastRowSrc4 - 4).Value = FileName
        wsDest.Range("B" & DestRow, "B" & DestRow + LastRowSrc4 - 4).Value = wsSource4.Name
        DestRow = DestRow + LastRowSrc4 - 3
        
        Application.CutCopyMode = False

        wbSource.Close SaveChanges:=False
        FileName = Dir
    Loop
End Sub

Hi, need to remove space , any idea please