PDA

View Full Version : [SOLVED] Import from a Number of Worksheets Listed in a Column



dj44
11-15-2016, 07:14 AM
Hi folks,

Good Tuesday all :)

I have a import data issue that Im trying to solve.


17603


I have put the code togther from other code I had.

I'm afraid its gone a bit pear shaped.





Dim i As Long
Dim ws As Worksheet
Dim oSourceWorksheet As Worksheet
Dim oImportToWorksheet As Worksheet
Dim strDir As String


Set ws = Worksheets("ImportList")

For i = 3 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

Set oSourceWorksheet = Worksheets(ws.Cells(i, "A").Value)

Set oImportToWorksheet = Application.ActiveWorkbook.Path & Worksheets(ws.Cells(i, "C").Value)

oSourceWorksheet.Range(ws.Cells(i, "C")).Copy Destination:=oImportToWorksheet.Range(ws.Cells(i, "E").Value)

Next i

End Sub



I saw Mr Bruins work, but that copied from 1 worksheet
http://www.rondebruin.nl/win/s3/win001.htm

The reason I need to do it this way is because It has formatting and other bits and bobs like hyperlinks, so if I don’t paste it in - I can import only the raw data and I will lose the good bits.

Is my code on the right track?

Thank you for your advice and time

mancubus
11-15-2016, 11:46 AM
since destination workbook is not stated i assumed it's the current workbook which the following code will be copied.

test with a copy of the original file.



Sub vbax_57724_import_from_listed_worksheets()

Dim ImpList
Dim i As Long
Dim CopyRng As Range

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With

With ThisWorkbook.Worksheets("ImportList")
With .Cells(1).CurrentRegion
ImpList = .Offset(2).Resize(.Rows.Count - 2).Value
End With
End With

For i = LBound(ImpList, 1) To UBound(ImpList, 1)
Workbooks.Open ImpList(i, 1)
With ActiveWorkbook
Set CopyRng = .Worksheets(ImpList(i, 2)).Range(ImpList(i, 3))
ThisWorkbook.Worksheets(ImpList(i, 4)).Range(ImpList(i, 5)).Resize(CopyRng.Rows.Count, CopyRng.Columns.Count).Value = CopyRng.Value
.Close False
End With
Next i

With Application
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With

End Sub

dj44
11-15-2016, 01:09 PM
Thank you Mancubus

This is an epic line, I will have to get my study glasses on for this :grinhalo:

ThisWorkbook.Worksheets(ImpList(i, 4)).Range(ImpList(i, 5)).Resize(CopyRng.Rows.Count, CopyRng.Columns.Count).Value = CopyRng.Value


It did the job

Thank you for helping

Have a good day !

:beerchug:

mancubus
11-16-2016, 02:19 AM
you are welcome

it's a good practice to prepare a guide especially when dealing with complex projects.

i personally dont use merged cells and 2 header lines, btw.