export data from file to another closed file with skip column

[Hasson]

Hi
I have data in file target from A2:F in sheet DATA and should copy column A to column D for file destenaion and columns B2:F to columns F2:G for sheet EXPORTED. the closed file is destenaiton when export data from open file target .
I have about 4000 rows
I try with this code , but doesn't work for me

Option Explicit

Sub UpdateData()
    Dim IntSht As Worksheet
    Dim IntBk As Workbook
    Dim ExtBk As Workbook
    Dim ExtFile As String


    Set IntBk = ActiveWorkbook
    Set IntSht = IntBk.ActiveSheet
    ExtFile = "C:\Users\PC Hass\Desktop\TABLES\ file.xlsm"
    If Dir(ExtFile) <> "" Then
  
        IntBk.Worksheets("Data").Range("a2:F4000").Value = ExtFile
    End If
    On Error Resume Next
    Set ExtBk = Workbooks(Dir(ExtFile))
    On Error GoTo 0
    If ExtBk Is Nothing Then
        Application.Workbooks.Open ExtFile
        Set ExtBk = Workbooks(Dir(ExtFile))
    End If
    IntBk.IntSht.Range("A2:F1000").Copy ExtBk.Worksheets("EXPORTED").Range("D" & Rows.Count).End(xlUp).Offset(1)
    Application.DisplayAlerts = False
    ExtBk.Save
    ExtBk.Close
    Application.DisplayAlerts = True
End Sub

target.xlsm
	A	B	C	D	E	F
1	ITEM	ID	QTY1	QTY2	QTY3	BALANCE
2	1	TT/W-1 MM CLA1 23M-1 IT	500			500
3	2	QQW-2 TH NM-1 CLA2 VBG L CHI				0
4	3	QQW-3 CV CLA3 TAI	700	33		733
5	4	QQW-4 M*12.5 CLA4 TR	200		12	188
6	5	QQW-5 CLA5 EG	300			300
7	6	MMR12/100 AS-1000/1 TMR	12	0	0	12
8	7	QQW-6 M230 TU	1			1
9	8	QQW-7 S** CLA7 US	1400		1	1399
10	9	QQW-8 CLA8 UK				0
11	10	QQW-9 CLA9 N BR	1600		1	1599
12	11	QQW-10 BN CLA10 IT	800	0	0	800
13	12	QQW-11 LVD CH	900			900
14	13	BB12 QQW-12 CLA12 JA11	1000		11	989
15	14	BB12 QQW-12 CLA12 JA12	2000		10	1990
16	15	BB12 QQW-12 CLA12 JA13	3000		10	2990
17	16	BB12 QQW-12 CLA12 JA14	4000		10	3990
18	17	BB12 QQW-12 CLA12 JA15	5000		10	4990
19	18	BB12 QQW-12 CLA12 JA16	6000		10	5990
20	19	BB12 QQW-12 CLA12 JA17	7000		10	6990
21	20	BB12 QQW-12 CLA12 JA18	8000		10	7990
22	21	BB12 QQW-12 CLA12 JA19	9000		10	8990
23	22	BB12 QQW-12 CLA12 JA20	10000		10	9990
DATA

Cell Formulas
Range	Formula
F2:F23	F2	=C2+D2-E2

before

destenation.xlsm
	D	E	F	G	H	I	J
1	ITEM	BATCH	ID	QTY1	QTY2	QTY3	BALANCE
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
EXPORTED

result should be like this

destenation.xlsm
	D	E	F	G	H	I	J
1	ITEM	BATCH	ID	QTY1	QTY2	QTY3	BALANCE
2	1		TT/W-1 MM CLA1 23M-1 IT	500			500
3	2		QQW-2 TH NM-1 CLA2 VBG L CHI				0
4	3		QQW-3 CV CLA3 TAI	700	33		733
5	4		QQW-4 M*12.5 CLA4 TR	200		12	188
6	5		QQW-5 CLA5 EG	300			300
7	6		MMR12/100 AS-1000/1 TMR	12	0	0	12
8	7		QQW-6 M230 TU	1			1
9	8		QQW-7 S** CLA7 US	1400		1	1399
10	9		QQW-8 CLA8 UK				0
11	10		QQW-9 CLA9 N BR	1600		1	1599
12	11		QQW-10 BN CLA10 IT	800	0	0	800
13	12		QQW-11 LVD CH	900			900
14	13		BB12 QQW-12 CLA12 JA11	1000		11	989
15	14		BB12 QQW-12 CLA12 JA12	2000		10	1990
16	15		BB12 QQW-12 CLA12 JA13	3000		10	2990
17	16		BB12 QQW-12 CLA12 JA14	4000		10	3990
18	17		BB12 QQW-12 CLA12 JA15	5000		10	4990
19	18		BB12 QQW-12 CLA12 JA16	6000		10	5990
20	19		BB12 QQW-12 CLA12 JA17	7000		10	6990
21	20		BB12 QQW-12 CLA12 JA18	8000		10	7990
22	21		BB12 QQW-12 CLA12 JA19	9000		10	8990
23	22		BB12 QQW-12 CLA12 JA20	10000		10	9990
EXPORTED

Cell Formulas
Range	Formula
J2:J23	J2	=G2+H2-I2

 

[Legacy 143009]

Sub OpenFilesFromFolder()
  Dim ExtBk As Workbook
  Dim IntBk As WorkBook
  Dim FolderPath As String
  Dim FilePath As String
  Dim lRow As Long
 
  IntBk = ActiveWorkbook
  lRow = IntBk.Worksheets("DATA").Cells(Rows.Count, 1).End(xlUp).Row

  FolderPath = "C:\Users\PC Hass\Desktop\TABLES\"
  FilePath = Dir(FolderPath & "file.xlsm")
  If FilePath <> "" Then
    Set ExtBk = Workbooks.Open(FolderPath & FilePath)
  End If
  Application.ScreenUpdating = False
  For i = 2 to lRow
    ExtBk.Worksheets("EXPORTED").Cells(i, 4).Value = IntBk.Worksheets("DATA").Cells(i, 1).Value
    ExtBk.Worksheets("EXPORTED").Cells(i, 6).Value = IntBk.Worksheets("DATA").Cells(i, 2).Value
    ExtBk.Worksheets("EXPORTED").Cells(i, 7).Value = IntBk.Worksheets("DATA").Cells(i, 3).Value
    ExtBk.Worksheets("EXPORTED").Cells(i, 8).Value = IntBk.Worksheets("DATA").Cells(i, 4).Value
    ExtBk.Worksheets("EXPORTED").Cells(i, 9).Value = IntBk.Worksheets("DATA").Cells(i, 5).Value
    ExtBk.Worksheets("EXPORTED").Cells(i, 10).Formula = "=G" & i & "+H" & i & "-I" & i
  Next
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
  ExtBk.Save
  ExtBk.Close
  Application.DisplayAlerts = True
End Sub

 

[Hasson]

thanks ! but unfortunately shows error object variable or with block variable not set in this line

IntBk = ActiveWorkbook

 

[Legacy 143009]

thanks ! but unfortunately shows error object variable or with block variable not set in this line

IntBk = ActiveWorkbook

Oh, it should include Set command:

Set IntBk = ActiveWorkbook

 

[Hasson]

thanks for your solution
strangely it takes more time when finish running despite of the data are not big , just 4000 rows !!

 

[Legacy 143009]

ı am not good at working with ranges. Maybe this could be a little bit faster:

Sub OpenFilesFromFolder()
  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("DATA").Cells(Rows.Count, 1).End(xlUp).Row

  FolderPath = "C:\Users\PC Hass\Desktop\TABLES\"
  FilePath = Dir(FolderPath & "file.xlsm")
  If FilePath <> "" Then
    Set ExtBk = Workbooks.Open(FolderPath & FilePath)
  End If
  Application.ScreenUpdating = False
  For i = 2 to lRow
    ExtBk.Worksheets("EXPORTED").Cells(i, 4).Value = IntBk.Worksheets("DATA").Cells(i, 1).Value
    ExtBk.Worksheets("EXPORTED").Cells(i, 10).Formula = "=G" & i & "+H" & i & "-I" & i
  Next
  Set Rng1 = IntBk.Worksheets("DATA").Range("B2:E" & lRow)
  Set Rng2 = ExtBk.Worksheets("EXPORTED").Range("F2:I" & lRow)
  Rng1.Copy
  Rng2.PasteSpecial xlPasteValues
  Application.ScreenUpdating = True
  Application.DisplayAlerts = False
  ExtBk.Save
  ExtBk.Close
  Application.DisplayAlerts = True
End Sub

 

[Hasson]

this is really much better
thanks very much for your help .

 

[Legacy 143009]

Glad it did help