combine two codes as in one for two different sheets whether input or output

[abdo meghari]

Hi experts
here are two codes to export data from open file to closed file and sheet to a different sheet .
my question , could make code short by combining as in one instead of Repeat the whole code twice for two closed file name and two different sheets names ?
so I have open file contains sheets TABLE 1& MISSED should export data to two closed files names Elmarghanie Brand & COMPARE REPORTS for sheets REPORT & OUTPUT .

Sub OpenFilesFromFolder1()
  Dim ExtBk As Workbook
  Dim IntBk As Workbook
  Dim FolderPath As String
  Dim FilePath As String
  Dim lRow As Long
  Dim Rng1 As Range, Rng2 As Range
 
  Set IntBk = ActiveWorkbook

  lRow = IntBk.Worksheets("TABLE 1").Cells(Rows.Count, 1).End(xlUp).Row

   FolderPath = "C:\Users\MY-NAME\Downloads\BRIDGESTONE REPORT\"
 
  FilePath = Dir(FolderPath & "Elmarghanie Brand .xlsm")
  If FilePath <> "" Then
    Set ExtBk = Workbooks.Open(FolderPath & FilePath)
  else   'Exit the sub if not found! Else errors will occur
     msgbox "File Elmarghanie Brand .xlsm not found"
     exit sub
  End If

  Application.ScreenUpdating = False
  'clear any old values:
  with ExtBk.Worksheets("TABLE 1")
      .Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).Clearcontents
  end with
'  For i = 2 To lRow
'
'    ExtBk.Worksheets("REPORT").Cells(i, 1).Value = IntBk.Worksheets("TABLE 1").Cells(i, 1).Value
'   
'  Next
'Why do the copy one row at a time? DO it all in once:
  ExtBk.Worksheets("REPORT").Range("A2:A"& lRow).Value = IntBk.Worksheets("TABLE 1").Range("A2:A"& lRow).Value
  Set Rng1 = IntBk.Worksheets("TABLE 1").Range("B2:E" & lRow)
  Set Rng2 = ExtBk.Worksheets("REPORT").Range("C2:F" & lRow)
'  Rng1.Copy
'  Rng2.PasteSpecial xlPasteValues
'' Range copy / paste is slow. Just set the values:
  rng2.Value = Rng1.Value
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
  ExtBk.Save
  ExtBk.Close
  Application.DisplayAlerts = True
End Sub

Sub OpenFilesFromFolder2()
  Dim ExtBk As Workbook
  Dim IntBk As Workbook
  Dim FolderPath As String
  Dim FilePath As String
  Dim lRow As Long
  Dim Rng1 As Range, Rng2 As Range
 
  Set IntBk = ActiveWorkbook

  lRow = IntBk.Worksheets("MISSED").Cells(Rows.Count, 1).End(xlUp).Row

   FolderPath = "C:\Users\MY-NAME\Downloads\BRIDGESTONE REPORT\"
 
  FilePath = Dir(FolderPath & "COMPARE REPORTS.xlsm")
  If FilePath <> "" Then
    Set ExtBk = Workbooks.Open(FolderPath & FilePath)
  else   'Exit the sub if not found! Else errors will occur
     msgbox "File COMPARE REPORTS.xlsm not found"
     exit sub
  End If

  Application.ScreenUpdating = False
  'clear any old values:
  with ExtBk.Worksheets("OUTPUT")
      .Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).Clearcontents
  end with
'  For i = 2 To lRow
'
'    ExtBk.Worksheets("OUTPUT").Cells(i, 1).Value = IntBk.Worksheets("MISSED").Cells(i, 1).Value
'   
'  Next
'Why do the copy one row at a time? DO it all in once:
  ExtBk.Worksheets("OUTPUT").Range("A2:A"& lRow).Value = IntBk.Worksheets("MISSED").Range("A2:A"& lRow).Value
  Set Rng1 = IntBk.Worksheets("MISSED").Range("B2:E" & lRow)
  Set Rng2 = ExtBk.Worksheets("OUTPUT").Range("C2:F" & lRow)
'  Rng1.Copy
'  Rng2.PasteSpecial xlPasteValues
'' Range copy / paste is slow. Just set the values:
  rng2.Value = Rng1.Value
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
  ExtBk.Save
  ExtBk.Close
  Application.DisplayAlerts = True
End Sub

I hope somebody could help for this .
thanks

 

[dmt32]

Hi,

Just make a common code & pass the values that change to it as arguments.



Untested but see if this update to your code will do what you want



Place in STANDARD module

Sub OpenFilesFromFolder(ByVal ExportToFileName As String, ByVal FolderPath As String, _
                        ByVal CopyFromSheetName As String, ByVal ExportToSheetName As String)
                                          
    Dim ExtBk           As Workbook, IntBk      As Workbook
    Dim FilePath        As String
    Dim lRow            As Long
    Dim Rng(1 To 2)     As Range
   
    On Error GoTo myerror
    Set IntBk = ActiveWorkbook
   
    lRow = IntBk.Worksheets(CopyFromSheetName).Cells(Rows.Count, 1).End(xlUp).Row
   
    FilePath = Dir(FolderPath & ExportToFileName)
   
    If FilePath <> "" Then
       
        Application.ScreenUpdating = False
        Set ExtBk = Workbooks.Open(FolderPath & FilePath, 0, False)
       
        'clear any old values:
        With ExtBk.Worksheets(CopyFromSheetName)
            .Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        End With
       
        'Why do the copy one row at a time? DO it all in once:
        ExtBk.Worksheets(ExportToSheetName).Range("A2:A" & lRow).Value = IntBk.Worksheets(CopyFromSheetName).Range("A2:A" & lRow).Value
        Set Rng(1) = IntBk.Worksheets(CopyFromSheetName).Range("B2:E" & lRow)
        Set Rng(2) = ExtBk.Worksheets(ExportToSheetName).Range("C2:F" & lRow)
       
        Rng(2).Value = Rng(1).Value
       
    Else
   
        'file not found
        Err.Raise 53, , ExportToFileName & Chr(10) & "File Not found"
       
    End If
   
myerror:
    Application.DisplayAlerts = False
    If Not ExtBk Is Nothing Then ExtBk.Close Err = 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

And to call it

Sub Test()

     Filename = "Elmarghanie Brand .xlsm"
     FolderPath = "C:\Users\MY-NAME\Downloads\BRIDGESTONE REPORT\"
     CopySheet = "TABLE 1"
     ExportSheet = "REPORT"
    
     OpenFilesFromFolder Filename, FolderPath, CopySheet, ExportSheet

End Sub

Dave

 

[abdo meghari]

Hi Dave ,
I no know why the error subscript out of range , despite of I make sure the sheets names and I used copy and paste to avoid error for sheets names matching but still shows error !!

 

[abdo meghari]

Hi Dave ,
you don't have any explanation for my problem ?

 

[dmt32]

Hi Dave ,
you don't have any explanation for my problem ?

Sorry, not had much availability this week

try replacing this this part of code

'clear any old values:
        With ExtBk.Worksheets(CopyFromSheetName)
            .Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        End With

with this

'clear any old values:
        With ExtBk.Worksheets(ExportToSheetName)
            .Range("A2:E" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        End With

and see if resolves

Dave

 

[abdo meghari]

thanks , the error message is gone , but unfortunately doesn't show any data for exported sheet for the closed file .

 

[dmt32]

Is there any data in Column A of the copy sheet?

Dave

 

[abdo meghari]

yes there are numbers 1,2,3....

 

[dmt32]

Can you post a copy of worksheet you are copying with dummy data using MrExcel Addin XL2BB - Excel Range to BBCode

 

[abdo meghari]

here data are in copy sheet for open file

Bridgestone Stock Sales report(2).xls
	A	B	C	D	E
1	ITEM	SIZE	PATTERN	ORIGIN	ARRIVED
2	1	BS 1200R20	G580	JAP	30
3	2	BS 1200R20	G580	THI
4	3	BS 1200R24	G582	JAP	2
5	4	BS 1200R20	R187	JAP	0
6	5	BS 1200R24	G580	JAP	50
7	6	BS 13R22.5	R187	JAP
8	7	BS 1400R20	R180	JAP
9	8	BS 1400R20	R180BZ	JAP
10	9	BS 1400R20	VSJ	JAP	22
11	10	BS 165R13C	R624	INDO	4
12	11	BS 175/70R13	EP150	THI
13	12	BS 185/65R15	B250	JAP
14	13	BS 195/75R16C	613V	JAP
15	14	BS 195R14C	613V	JAP
16	15	BS 195R14C	R623	THI
17	16	BS 195R15C	613V	JAP	4
18	17	BS 205/60R16	T005	THI	0
19	18	BS 205/70R15C	R623	THI	8
20	19	BS 205R16C	D840	THI
21	20	BS 215/50R17	EP300	THI
22	21	BS 215/55R17	T005	JAP
23	22	BS 215/60R16	ER30	JAP	8
24	23	BS 215/65R15	T005	INDO	4
25	24	BS 215/70R15C	R624	TR
TABLE 1