Macro to run in files inside a folder

[dinunan]

Hello All
I am trying to write one macro to run on 3 files inside a folder. Code is written but it copies data and overwrites in the same range for next files. I want data from source file to go in target file range G5:G32 for 1 st file/E5:E32 for second file and F5:F32 for third file. Each source file has two sheets to bring data from. Also target file has two sheets for the data to go into. Here is the code so far. Trying offset but no success!

Sub LoopThroughFolder()


Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook

MyDir = "C:\MacrosTest\Folder Testing"
MyFile = Dir(MyDir & "*.xlsx")
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0


Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets(1)
Set Rng = Range(.Cells(5, "N"), .Cells(32, "N"))
Rng.Copy Wb.Worksheets("BATTERY10").Cells(5, "G")
End With

With Worksheets(2)
Set Rng = Range(.Cells(5, "N"), .Cells(34, "N"))
Rng.Copy Wb.Worksheets("UNIT 700").Cells(5, "G")
ActiveWorkbook.Close True

End With
MyFile = Dir()
Loop


End Sub

 

[Fluff]

Try

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Fldr As String
    Dim Rws As Long, Rng As Range
    Dim Cnt As Long
    Dim Col As String
    Set Wb = ThisWorkbook


Application.ScreenUpdating = 0
Application.DisplayAlerts = 0


    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\MacrosTest"
        .Title = "Please select a folder"
        If .Show = -1 Then
            Fldr = .SelectedItems(1)
        End If
    End With
    
    ChDir Fldr
    MyFile = Dir(Fldr & "\*.xlsx")
    
    Cnt = 1
    Do While MyFile <> ""
        Workbooks.Open (MyFile)

 

[dinunan]

Hey
It is working. I got the error on code line 'Chdir Fldr'. Changed that to comment and it worked. Also I need to select first file (when folder dialogue opens) and then code runs on all the other automatically. Same as previous code. Great!!

 

[Fluff]

Also I need to select first file (when folder dialogue opens) and then code runs on all the other automatically

There is no need to select a file, the code provided will run on all .xlsx files in the selected folder.

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Fldr As String
    Dim Rws As Long, Rng As Range
    Dim Cnt As Long
    Dim Col As String
    Set Wb = ThisWorkbook


Application.ScreenUpdating = 0
Application.DisplayAlerts = 0


    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\MacrosTest"
        .Title = "Please select a folder"
        If .Show = -1 Then
            Fldr = .SelectedItems(1)
        End If
    End With
    
'    ChDir Fldr
    MyFile = Dir(Fldr & "\*.xlsx")
    
    Cnt = 1
    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        Select Case Cnt
            Case 1
                Col = "G"
            Case 2
                Col = "E"
            Case 3
                Col = "F"
        End Select
            
        With Worksheets(1)
            Set Rng = .Range(.Cells(5, "N"), .Cells(32, "N"))
            Rng.Copy Wb.Worksheets("BATTERY10").Cells(5, Col)
        End With
        
        With Worksheets(2)
            Set Rng = .Range(.Cells(5, "N"), .Cells(34, "N"))
            Rng.Copy Wb.Worksheets("UNIT 700").Cells(5, Col)
            ActiveWorkbook.Close True
            Cnt = Cnt + 1
        End With
        MyFile = Dir()
    Loop
Application.DisplayAlerts = True
End Sub

 

[dinunan]

Hi Again!
I've one excel file called as 'Daily Mass Balance....' having 30/31 sheets i.e one for each day plus one from previous month. I would like to pick up cell values from H53:H58 and paste it to another excel file called as 'Production Calendar.....'. I wrote one code using 'For Each - Next loop' and it is working. The problem is code runs from rightmost sheet to left. This brings latest date values on top but I want it the opposite. Means I want the code to run from Left to right. Presently my code is working fine but I would like to know how to run the from right to left!!

Sub ProductionCalender()


' Updates values from Mass Balance Report


Dim ws As Worksheet
Application.ScreenUpdating = False
Range("AF8").Activate

Workbooks.Open Filename:="C:\MacrosTest\8.Daily Mass Balance Report, Aug-2017.xlsx"
Worksheets("01-Aug 2017").Activate

For Each ws In Sheets

Range("H53:H58").Select
Selection.Copy

Windows("Production Calender 2017.xlsm").Activate

ActiveCell.Offset(0, 0).Range("A1:F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

ActiveCell.Offset(1, 0).Activate

Windows("8.Daily Mass Balance Report, Aug-2017").Activate
ActiveSheet.Previous.Select
On Error GoTo exiterr
Next ws
exiterr:

Application.CutCopyMode = False
ActiveWorkbook.Close

End Sub

 

[Fluff]

As this is a completely new question & unrelated to the thread you need to start a new thread
Cheers

 

[dinunan]

Hi Again
Due to some system changes, I am now having total six files in the said folder. Three files with extension .xlsx and three with .xls. Since code only considers .xlsx files, I'm not getting the expected result. So I copied the code and made another subroutine in the same macro below first one. Its working fine for xlsx files as previous but while copying from .xls files and pasting to target file, it pastes first range and then before pasting second range, it deletes previously pasted range in neighboring column.
Please help to stop this behavior!
Regards

 

[Fluff]

You don't need a separate macro, just change this line as shown

    MyFile = Dir(Fldr & "\*.xls[COLOR=#ff0000]*[/COLOR]")

 

[dinunan]

You don't need a separate macro, just change this line as shown

    MyFile = Dir(Fldr & "\*.xls[COLOR=#ff0000]*[/COLOR]")

Its working but I am having other issue. I would like the code to run only on worksheet(1) of .xls files and worksheet(2) of .xlsx files.
(worksheet(2) of .xls files have error values in the said range, similarly worksheet(1) of .xlsx file. These errors getting copied now)

 

[Fluff]

Try

Sub LoopThroughFolder()

   Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
   Dim Fldr As String
   Dim Rws As Long, Rng As Range
   Dim Cnt As Long
   Dim Col As String
   Set Wb = ThisWorkbook
   
   Application.ScreenUpdating = 0
   Application.DisplayAlerts = 0
   
   With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = "C:\MacrosTest"
      .Title = "Please select a folder"
      If .Show = -1 Then
         Fldr = .SelectedItems(1)
      End If
   End With
   
   '    ChDir Fldr
   MyFile = Dir(Fldr & "\*.xls*")
   
   Cnt = 1
   Do While MyFile <> ""
      Workbooks.Open (MyFile)
      Select Case Cnt
         Case 1
            Col = "G"
         Case 2
            Col = "E"
         Case 3
            Col = "F"
      End Select
      If Right(MyFile, 1) = "s" Then
         With Worksheets(1)
            Set Rng = .Range(.Cells(5, "N"), .Cells(32, "N"))
            Rng.Copy Wb.Worksheets("BATTERY10").Cells(5, Col)
         End With
      Else
         With Worksheets(2)
            Set Rng = .Range(.Cells(5, "N"), .Cells(34, "N"))
            Rng.Copy Wb.Worksheets("UNIT 700").Cells(5, Col)
         End With
      End If
      ActiveWorkbook.Close True
      Cnt = Cnt + 1
      MyFile = Dir()
   Loop
Application.DisplayAlerts = True
End Sub

 

[dinunan]

Now its working one at a time i.e. xls and xlsx files/worksheets separately and not copy pasting error values from other sheets. But the problem is, with xls files, it copies and pastes data in "G" column and then before pasting data for "E" column, it is deleting "G" content. Again for "F" its working fine. Means I've data in "E" and "F" but "G" is empty! (with xlsx files this behavior is not there!)

How to stop this deleting? (why is it happening?)

Regards.