Link to home
Start Free TrialLog in
Avatar of Share Point
Share Point

asked on

Need help to format Excel by VBA code

Hi Experts,
 I have one Excel file in one folder (C:/Source). I have also on Macro enable excel file where i need to copy source data to Macro enabled file with formatting. I need your help to write Macro to get file from Source folder and paste to Output tab.    I am attaching Input and Report file with sample data,

Can you please help me?

Source File

User generated image
Desired Output
User generated imageInput-FIle.xlsx
Report.xlsm
Avatar of Subodh Tiwari (Neeraj)
Subodh Tiwari (Neeraj)
Flag of India image

You may try something like this...

Please remember to change the Source Folder Path and Source File Name on first two lines of the code if required.


Const strSourcePath       As String = "C:\Source\"
Const strSourceFileName   As String = "Input-File.xlsx"

Sub getDataFromFile()
Dim wbSource    As Workbook
Dim wbDest      As Workbook
Dim wsSource    As Worksheet
Dim wsDest      As Worksheet
Dim Rng         As Range
Dim rngToCopy   As Range
Dim LR          As Long
Dim DLR         As Long
Dim fso         As Object
Dim Company     As String

Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(strSourcePath) Then
    MsgBox "The Source folder was not found!", vbExclamation, "Folder Doesn't Exist!"
    Exit Sub
ElseIf Not fso.FileExists(strSourcePath & strSourceFileName) Then
    MsgBox "The Source File was not found!", vbExclamation, "Source File Not Found!"
    Exit Sub
End If

Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Output")
wsDest.Range("A1").CurrentRegion.Offset(1).Clear

Set wbSource = Workbooks.Open(strSourcePath & strSourceFileName)
Set wsSource = wbSource.Worksheets(1)

LR = wsSource.Cells(Rows.Count, "B").End(xlUp).Row

For Each Rng In wsSource.Range("B2:B" & LR).SpecialCells(xlCellTypeConstants, 3).Areas
    If Rng.Cells(1).Value = "Account" Then
        Company = Split(Rng.Cells(1).Offset(-2, 0).Value, " ")(0)
        Set rngToCopy = wsSource.Range(Rng.Cells(1).Offset(1, 0), Rng.Cells(1).Offset(1, 0).End(xlToRight).End(xlDown))
        DLR = wsDest.Cells(Rows.Count, "B").End(xlUp).Row + 1
        rngToCopy.Copy wsDest.Range("B" & DLR)
        wsDest.Range("A" & DLR).Value = Company
    End If
Next Rng

wbSource.Close False

DLR = wsDest.Cells(Rows.Count, "B").End(xlUp).Row

wsDest.Range("A2:A" & DLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
wsDest.Range("A2:A" & DLR).Value = wsDest.Range("A2:A" & DLR).Value
wsDest.Range("A1").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True

End Sub

Open in new window


In the attached, click the Run button to test the code.

Report.xlsm


Do you have any control over the input file ?

If so, a power BI solution will be better than VBA (users will only need to click te refresh button in the ribbon).


In the input file:

1st, add a "Company column", its value will be an absolute reference to the company code (AR00 or BR10 in your case). Hide it.
2nd, insert 2 data-tables (one for each table).
3rd save and close.


In the report file:

Create 3 queries:
1st one will retrieve data from the 1st table (connection only).
2nd one will retrieve data from the 2nd table (connection only).
3rd one will merge queries 1 and 2 and load into a sheet.


See the attached samples.Input-FIle.xlsxReport.xlsx


Avatar of Share Point
Share Point

ASKER

Hi Neeraj,
 Thank you for the code. It's working fine with the sample file i have provided but did not work properly with another file (More data). Can you please take a look attached file?

Input-FIle_New.xlsx

Fabrice,

 Thanks for the solution. I will take a look but i my have to stick with macro since we already another macro for other functionality.

Please replace the existing code with the following one and see if that works as desired.


Const strSourcePath       As String = "C:\Source\"
Const strSourceFileName   As String = "Input-File.xlsx"

Sub getDataFromFile()
Dim wbSource    As Workbook
Dim wbDest      As Workbook
Dim wsSource    As Worksheet
Dim wsDest      As Worksheet
Dim Rng         As Range
Dim rngToCopy   As Range
Dim LR          As Long
Dim DLR         As Long
Dim fso         As Object
Dim Company     As String

Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(strSourcePath) Then
    MsgBox "The Source folder was not found!", vbExclamation, "Folder Doesn't Exist!"
    Exit Sub
ElseIf Not fso.FileExists(strSourcePath & strSourceFileName) Then
    MsgBox "The Source File was not found!", vbExclamation, "Source File Not Found!"
    Exit Sub
End If

Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("Output")
wsDest.Range("A1").CurrentRegion.Offset(1).Clear

Set wbSource = Workbooks.Open(strSourcePath & strSourceFileName)
Set wsSource = wbSource.Worksheets(1)

LR = wsSource.Cells(Rows.Count, "B").End(xlUp).Row

For Each Rng In wsSource.Range("B2:B" & LR).SpecialCells(xlCellTypeConstants, 3).Areas
    If Rng.Cells(1).Value = "Account" Then
        Company = Split(Rng.Cells(1).Offset(-2, 0).Value, " ")(0)
        Set rngToCopy = wsSource.Range(Rng.Cells(1).Offset(1, 0), Rng.Cells(1).End(xlToRight).End(xlDown))
        DLR = wsDest.Cells(Rows.Count, "B").End(xlUp).Row + 1
        rngToCopy.Copy wsDest.Range("B" & DLR)
        wsDest.Range("A" & DLR).Value = Company
    End If
Next Rng

wbSource.Close False

DLR = wsDest.Cells(Rows.Count, "B").End(xlUp).Row

wsDest.Range("A2:A" & DLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
wsDest.Range("A2:A" & DLR).Value = wsDest.Range("A2:A" & DLR).Value
wsDest.Range("A1").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True

End Sub

Open in new window

Thanks a lot Neeraj. I will test and let you know. I have couples of questions for you.
 1. If we have more than one files with same name , is it possible to select file with last modify date as input file?
 2. Also is it possible to copy input file as it is with different tab within Report file for backup?
ASKER CERTIFIED SOLUTION
Avatar of Subodh Tiwari (Neeraj)
Subodh Tiwari (Neeraj)
Flag of India image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Thank you so much Neeraj for your quick help.

You're welcome!