copy from a workbook to 4 workboos that i need to create

tonito17

New Member
Joined
Jan 3, 2017
Messages
1
I want to open a file and then interogate it to see if it contains data i need. If i find it I want to create a file to export the data there. I have 4 workbooks that i need to create. The source workbook has one sheet, and the portalworkbooks also. The source worksheet has a lot of line and columns but what i need to search i know it is in the column 4. So all i need to do is compare cell(i,4) = data i want and then export it to the specific file. I have to go trough all the source worksheet. It gives me and error 9. out of range Pls help. I'm doing something wrong manipulating objects in here. Thanks in advance

------------------------------------------------------------------------

Sub Deschide()
Dim portalwkb1, portalwkb2, portalwkb3, portalwkb4 As Workbook, sourcewkb As Workbook
Dim Ret1, Ret2
Dim srcws As Worksheet ' Variable for source workbook worksheets
Dim portalws1, portalws2, portalws3, portalws4 As Worksheet ' Variable for portal workbook worksheets
Dim srcLR, i, j, k, l, m As Long ' last row of the source worksheet
Const Coloana As Long = 4
Dim rng As Range


Set portalwkb1 = Workbooks.Add
With portalwkb1

.SaveAs Filename:="N.xls"
End With
Set portalwkb2 = Workbooks.Add
With portalwkb2

.SaveAs Filename:="C.xls"
End With
Set portalwkb3 = Workbooks.Add
With portalwkb3

.SaveAs Filename:="I.xls"
End With
Set portalwkb4 = Workbooks.Add
With portalwkb4

.SaveAs Filename:="L.xls"
End With

'~~> Get the first File
Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select the source file file")
If Ret1 = False Then
' Tell the user why the code has been terminated
MsgBox ("Nu ai ales nici un fisier! Rutina se va termina!")
End
End If
' Open the Source file
Set sourcewkb = Workbooks.Open(Ret1)
' Set the source worksheet
Set srcws = sourcewkb.Sheets(1)

' Set the first destination worksheet
Set portalws1 = portalwkb1.Sheets(1)
Set portalws2 = portalwkb2.Sheets(1)
Set portalws3 = portalwkb3.Sheets(1)
Set portalws4 = portalwkb4.Sheets(1)
k = 1
l = 1
j = 1
m = 1



'Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
' Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value

'Find the last row of data in the Source worksheet
srcLR = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To srcLR
If srcws.Cells(i, Coloana) = "data to compare" Then
portalws1.Range("A[j]:A[100]") = srcws.Range("A:A[100]").Value
j = j + 1
ElseIf srcws.Cells(i, Coloana) = "data to compare" Then
Set portalws2 = portalwkb2.Sheets(1)
portalws2.Range("A[k]").Value = sourcewkb.Worksheets("Sheet1").Range("A").Value
k = k + 1
ElseIf srcws.Cells(i, Coloana) = "data to compare" Then
portalws3.Range("A[l]:A[100]") = srcws.Range("A:A[100]").Value
l = l + 1
ElseIf srcws.Cells(i, Coloana) = "data to compare" Then
portalws4.Range("A[m]:A[100]") = srcws.Range("A:A[100]").Value
m = m + 1
End If
Next i


' close the source workbook, don't save any changes
sourcewkb.Close SaveChanges:=False
portalwkb1.Close SaveChanges:=True
portalwkb2.Close SaveChanges:=True
portalwkb3.Close SaveChanges:=True
portalwkb4.Close SaveChanges:=True
' Clear the objects
Set srcws = Nothing
Set sourcewkb = Nothing
Set portalws1 = Nothing
Set portalws2 = Nothing
Set portalws3 = Nothing
Set portalws4 = Nothing
Set portalwkb1 = Nothing
Set portalwkb2 = Nothing
Set portalwkb3 = Nothing
Set portalwkb4 = Nothing
End Sub
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Forum statistics

Threads
1,214,983
Messages
6,122,598
Members
449,089
Latest member
Motoracer88

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