"Help needed!" in VBA Code for find the issue

nkashyap3

New Member
Joined
Jun 27, 2019
Messages
24
Office Version
  1. 2010
Platform
  1. Windows
I have search much old thread but not getting the solution, I am able to find the error in my coding , Its look fine but in test run is not working,according to my step. below coding is some part of coding:-

1-I have files folder and there are many sub folders ( Name and number of count sub folder is not fixed). also path is not fixed every month will change the path
2- I have done the coding to get the sub folder(Dir) path list and folder name List on macro sheet also create the tab in macro file according the sub folder name. below is sample.

Path Dir of Sub folderfolder Dirfolder Name
C:\Users\nkashyap3\Desktop\New folder (2)\FMG\C:\Users\nkashyap3\Desktop\New folder (2)\FMG
C:\Users\nkashyap3\Desktop\New folder (2)\Travel\C:\Users\nkashyap3\Desktop\New folder (2)\
Travel

<tbody>
</tbody>

<tbody>
</tbody>


3- now below coding is for to open each sub folder one by one and complied the excel files and paste in macro file according to sub folder name.
4- (My cell) is store the sub folder name list

Sub kkkk()
Dim Fpath As String
Dim Fname As String
Dim Wkb As Workbook
Dim ws As Worksheet
Dim MyCell As Range
Dim MyRange As Range

Sheets("path").Select




Set MyRange = Sheets("path").Range("C3")

Set MyRange = Range(MyRange, MyRange.End(xlDown));


LRow = Cells(Rows.Count, 1).End(xlUp).Row
Lcol = Cells(1, Columns.Count).End(xlToLeft).Column




For Each MyCell In MyRange

a = MyCell

For I = 3 To LRow




Fpath = Cells(I, 1).Value

Fname = Dir(Fpath & "*.xls*")

Sheets(a).Activate
Sheets(a).Cells(1).Resize(1, 13).Value = Array("DeptID", "DeptID Description", "Month Ending", "Date Run", "Project", "Account", "Account Description", "Business Unit", "Journal ID", "EffDate", "Source", "Description", "Amount")


Do Until Fname = ""

Set wb = Workbooks.Open(Filename:=Fpath & Fname)

ActiveSheet.Cells(2, 1).EntireRow.Select

'Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Windows("test.xlsm").Activate

Sheets(a).Activate

NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
Cells(NextRow, 1).Select

ActiveSheet.Paste

Workbooks(Fname).Close
Application.DisplayAlerts = False
Fname = Dir()
Loop




sheets("path").Select

Next I

Next MyCell

End Sub
-----------------------------------------------
issue- Its running good in Do until loop for complied the all excel sheet in a folder and store the (Next i) statement "Stored the next folder path , but not store (Next MyCell) for
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
I have search much old thread but not getting the solution, I am able to find the error in my coding , Its look fine but in test run is not working,according to my step. below coding is some part of coding:-

1-I have files folder and there are many sub folders ( Name and number of count sub folder is not fixed). also path is not fixed every month will change the path
2- I have done the coding to get the sub folder(Dir) path list and folder name List on macro sheet also create the tab in macro file according the sub folder name. below is sample.

Path Dir of Sub folderfolder Dirfolder Name
C:\Users\nkashyap3\Desktop\New folder (2)\FMG\C:\Users\nkashyap3\Desktop\New folder (2)\FMG
C:\Users\nkashyap3\Desktop\New folder (2)\Travel\C:\Users\nkashyap3\Desktop\New folder (2)\
Travel

<tbody>
</tbody>

<tbody>
</tbody>


3- now below coding is for to open each sub folder one by one and complied the excel files and paste in macro file according to sub folder name.
4- (My cell) is store the sub folder name list


-----------------------------------------------
issue- Its running good in Do until loop for complied the all excel sheet in a folder and store the (Next i) statement "Stored the next folder path , but not store (Next MyCell) for


I think you do not need the for each Cell. You just have to put the value of column C in variable a.
Try and tell me.


Code:
Sub kkkk()
    Dim Fpath As String
    Dim Fname As String
    Dim Wkb As Workbook
    Dim ws As Worksheet
    Dim MyCell As Range
    Dim MyRange As Range
    
    Sheets("path").Select
    'Set MyRange = Sheets("path").Range("C3")
    'Set MyRange = Range(MyRange, MyRange.End(xlDown))
    
    LRow = Cells(Rows.Count, 1).End(xlUp).Row
    Lcol = Cells(1, Columns.Count).End(xlToLeft).Column
    'For Each MyCell In MyRange
    'a = MyCell
    For i = 3 To LRow
        Fpath = Cells(i, 1).Value
[B][COLOR=#0000ff]        a = Cells(i, "C").Value[/COLOR][/B]
        Fname = Dir(Fpath & "*.xls*")
        Sheets(a).Activate
        Sheets(a).Cells(1).Resize(1, 13).Value = Array("DeptID", "DeptID Description", "Month Ending", "Date Run", "Project", "Account", "Account Description", "Business Unit", "Journal ID", "EffDate", "Source", "Description", "Amount")
        Do Until Fname = ""
            Set wb = Workbooks.Open(Filename:=Fpath & Fname)
            ActiveSheet.Cells(2, 1).EntireRow.Select
            'Range(Selection, Selection.End(xlToRight)).Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            Windows("test.xlsm").Activate
            Sheets(a).Activate
            NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Workbooks(Fname).Close
            Application.DisplayAlerts = False
            Fname = Dir()
        Loop
        Sheets("path").Select
    Next i
    'Next MyCell
End Sub
 
Upvote 0
Its working fine now thank you so much !
 
Last edited by a moderator:
Upvote 0

Forum statistics

Threads
1,213,514
Messages
6,114,078
Members
448,547
Latest member
arndtea

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top