PDA

View Full Version : Solved: Macros across workbboks



Anomandaris
05-12-2009, 01:53 AM
Hi guys, I have this code, the macro is in a workbook called Book3 with some data in Sheet2, I need the macro to use that data to give a certain output in another Workbook("Aro") in a sheet called "Roll"

This is the code I have, it gives me an error mesg saying subscript is out of range, how do i adjust it?
Thanks


Dim LR1 As Long, a As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim c As Range, firstaddress As String
Application.ScreenUpdating = False
Set ws1 = Workbooks("Aro").Sheets("Roll")
Set ws2 = Workbooks("Book3").Sheets("Sheet2")
With ws1
LR1 = .Cells(Rows.Count, 2).End(xlUp).Row
For a = 2 To LR1 Step 1
With ws2.Columns(1)
Set c = .Find(ws1.Cells(a, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstaddress = c.Address
Do
ws1.Cells(a, 2) = c.Offset(, 1)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
Next a
End With
Application.ScreenUpdating = True

JONvdHeyden
05-12-2009, 02:25 AM
Perhaps you can avoid a loop and use a Vlookup. Something like this perhaps:

Sub GetData()
Dim wsSrc As Worksheet
Dim wsDest As Worksheet
Dim lngLastRow As Long
Dim rngDest As Range
Set wsSrc = Workbooks("Book3.xls").Sheets("Sheet2")
Set wsDest = Workbooks("Aro.xls").Sheets("Roll")
lngLastRow = wsDest.Cells(Rows.Count, 2).End(xlUp).Row
Set rngDest = wsDest.Range("B2:B" & lngLastRow)
rngDest = Application.VLookup(rngDest, wsSrc.Range("A:B"), 2, 0)
End Sub

Bob Phillips
05-12-2009, 02:26 AM
That suggests one of the books/sheets doesn't exist, but we would need a workbook example to track it down.

JONvdHeyden
05-12-2009, 02:46 AM
I had the same error in my example but adding the '.xls' to the book name seemed to make it work.

Anomandaris
05-12-2009, 04:12 AM
Hi Jon,

thanks that works, but problem is when I add the code into a larger code it doesnt work

you're right xld, i throw in some wkbks so you can see what im trying to do
I'll open a new thread and add attachments ---i cant seem to add it here

JONvdHeyden
05-12-2009, 04:19 AM
Hi Jon,

thanks that works, but problem is when I add the code into a larger code it doesnt work


In what way won't it work? It's bound to be more efficient (and simpler) than the loop method that you are currently using...

Anomandaris
05-12-2009, 04:35 AM
I oprened a new thread to add an attachment - (Xld and JonHayden you are familiar with some of this code)

Ok this is what the overall code looks like

Sub Ty()

Dim Filename As Variant
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim strDate As String
strDate = Format(Date, "dd-mm-yy") & "." & Format(Time, "hh-mm-ss")


Filename = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If Filename <> False Then

Set wbSource = Workbooks.Open(Filename)
wbSource.Worksheets("Roll").Copy
Set wbTarget = ActiveWorkbook

'your code
Dim i As Long
Dim rng As Range

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With



With Worksheets("Roll")

i = 2
Do

If .Cells(i, "A").Value = "" Or ( _
.Cells(i, "F").Value = "" And .Cells(i, "G").Value = "") Then

If rng Is Nothing Then

Set rng = .Rows(i)
Else

Set rng = Union(rng, .Rows(i))
End If
End If

.Cells(i, "C").Value = .Cells(i, "F").Value + .Cells(i, "G").Value
.Cells(i, "A").Value = IIf(.Cells(i, "C").Value < 0, "out", "in")
.Cells(i, "C").Value = Abs(.Cells(i, "C").Value)
If .Cells(i, "F").Value Then .Cells(i, "H").Value = 100
If .Cells(i, "G").Value Then .Cells(i, "H").Value = 200
.Cells(i, "D").Resize(, 4).Value = Array("colour", "annual", "", "")
i = i + 1
Loop Until .Cells(i, "A").Value = "ACTION"

If rng Is Nothing Then

Set rng = .Rows(i)
Else

Set rng = Union(rng, .Rows(i))
End If

rng.Delete

.Range("A1:H1").Value = Array("Cashflow", "ID", "Qty", "Category", "Duration", "", "", "File#")
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With


Dim wsSrc As Worksheet
Dim wsDest As Worksheet
Dim lngLastRow As Long
Dim rngDest As Range
Set wsSrc = Workbooks("Book3.xls").Sheets("Sheet2")
Set wsDest = Workbooks("Aro.xls").Sheets("Roll")
lngLastRow = wsDest.Cells(Rows.Count, 2).End(xlUp).Row
Set rngDest = wsDest.Range("B2:B" & lngLastRow)
rngDest = Application.VLookup(rngDest, wsSrc.Range("A:B"), 2, 0)

wbTarget.SaveAs "Aro1" & "" & strDate & ".xls"

wbTarget.Close
wbSource.Close SaveChanges:=False
MsgBox "The OMS import file was saved in:" & "Aro1.xls" & "" & strDate

End If
End Sub




So basically Book 3 has the macro with a button on sheet 1. On Sheet 2 there is a mapping guide that changes ID value.
The macro first opens dialog box, we select Wkbook called "Aro", on Aro there is a Worksheet "Roll"...macro copies this sheet into a new Workbook and then rearranges the data and saves the file as "Aro1" . Here Column B values "ID" needs to be changed according to the guide in Book3 "Sheet2", but this part isnt working.


so here are the files----i just realized i can only upload only 1 workbook.......so what I'm doing is throwing in all the sheets in one workbook,
Sheet 1 and sheet2 are for Wkbk "Book3", Sheet 3 is "Roll" from Wkbook "Aro", and Sheet 4 is the final solution that is saved in a new Workbook "Aro1".



thanks

Anomandaris
05-12-2009, 05:31 AM
Hey Jon,

it works when by itself but when I put it into a larger code it doesnt work.....neither does my loop code...i think it may have something to do with the 'Dim Workbook' part as there's a few of those

here check it out


Sub Ty()

Dim Filename As Variant
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim strDate As String
strDate = Format(Date, "dd-mm-yy") & "." & Format(Time, "hh-mm-ss")


Filename = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If Filename <> False Then

Set wbSource = Workbooks.Open(Filename)
wbSource.Worksheets("Roll").Copy
Set wbTarget = ActiveWorkbook

'your code
Dim i As Long
Dim rng As Range

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With



With Worksheets("Roll")

i = 2
Do

If .Cells(i, "A").Value = "" Or ( _
.Cells(i, "F").Value = "" And .Cells(i, "G").Value = "") Then

If rng Is Nothing Then

Set rng = .Rows(i)
Else

Set rng = Union(rng, .Rows(i))
End If
End If

.Cells(i, "C").Value = .Cells(i, "F").Value + .Cells(i, "G").Value
.Cells(i, "A").Value = IIf(.Cells(i, "C").Value < 0, "out", "in")
.Cells(i, "C").Value = Abs(.Cells(i, "C").Value)
If .Cells(i, "F").Value Then .Cells(i, "H").Value = 100
If .Cells(i, "G").Value Then .Cells(i, "H").Value = 200
.Cells(i, "D").Resize(, 4).Value = Array("colour", "annual", "", "")
i = i + 1
Loop Until .Cells(i, "A").Value = "ACTION"

If rng Is Nothing Then

Set rng = .Rows(i)
Else

Set rng = Union(rng, .Rows(i))
End If

rng.Delete

.Range("A1:H1").Value = Array("Cashflow", "ID", "Qty", "Category", "Duration", "", "", "File#")
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With


Dim wsSrc As Worksheet
Dim wsDest As Worksheet
Dim lngLastRow As Long
Dim rngDest As Range
Set wsSrc = Workbooks("Book3.xls").Sheets("Sheet2")
Set wsDest = Workbooks("Aro.xls").Sheets("Roll")
lngLastRow = wsDest.Cells(Rows.Count, 2).End(xlUp).Row
Set rngDest = wsDest.Range("B2:B" & lngLastRow)
rngDest = Application.VLookup(rngDest, wsSrc.Range("A:B"), 2, 0)

wbTarget.SaveAs "Aro1" & "" & strDate & ".xls"

wbTarget.Close
wbSource.Close SaveChanges:=False
MsgBox "The OMS import file was saved in:" & "Aro1.xls" & "" & strDate

End If
End Sub

lucas
05-12-2009, 06:39 AM
Threads merged

Anomandaris
05-12-2009, 06:41 AM
thanks lucas

Anomandaris
05-12-2009, 09:58 AM
any idea guys how i should change it?
i'm thinking it has to be the workbook and worksheet variables, maybe there's too many Dim functions referring to them

thanks

Anomandaris
05-13-2009, 02:50 AM
sorry if im annoying you guys, but please can anyone point out where the mistake is.....Xld i need you dude, come to my rescue yet again...

Anomandaris
05-14-2009, 06:40 AM
Ah I figured it out --- instead of wsDest I just needed to have Sheets("Roll")

thanks guys