Extract data from one workbook to another

[GeorgeB]

Can't seem to get the syntax right to open the workbook named in the input box. In this case VMNB123 but this will vary but it will be open at the same time as the target workbook. Is this a great forum or what?


Sub ImportJob()
'Imports all data for a new job
Dim JobCode As Variant
Dim sht As Variant
On Error GoTo errhand

JobCode = InputBox(prompt:="", Title:="INPUT THE JOB CODE")
If JobCode = "" Then
MsgBox prompt:="", Title:="NOTHING ENTERED"
Exit Sub
End If

Application.ScreenUpdating = False
Windows("VMNB123.xls").Activate
For Each sht In ActiveWorkbook.Worksheets
Windows("VMNB123.xls").Activate
Range("B18:D37").Select
Selection.Copy
Range("A1").Select
Windows("Pay Verification.xls").Activate
Range("E65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

Range("B65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
Selection.FormulaR1C1 = JobCode
Range("C65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
Selection.FormulaR1C1 = sht.Name
Range("D65536").End(xlUp).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
ActiveSheet.Paste
Range("H65536").End(xlUp).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(19, 0)).Select

ActiveSheet.Paste
Selection.NumberFormat = "0.00"
Application.CutCopyMode = False
Range("A1").Select

Next sht
errhand:
MsgBox prompt:="", Title:="ERROR, TRY AGAIN"

End Sub

 

[GeorgeB]

Eureka it works.
However the Tab name is supposed to copy to column C. It does but does not change with the info. In other words it copies the Tab name of the first sheet for all three cycles of the loop.

 

[GeorgeB]

Oh and here's the code:

Sub ImportJob()
'Imports all data for a new job into Pay Verification2
Dim JobCode As Variant
Dim sht As Worksheet
Dim CurrentSheetName As Variant
'On Error GoTo errhand
'Ask for the Job Code
JobCode = InputBox(Prompt:="", Title:="INPUT THE JOB CODE")
If JobCode = "" Then
MsgBox Prompt:="", Title:="NOTHING ENTERED"
Exit Sub
End If
Application.ScreenUpdating = False
'Open the Job inputed by user
'Loop through the workbook and extract the data
Workbooks(JobCode).Activate
For Each sht In Workbooks(JobCode).Worksheets
'Copy the desired data
sht.Range("B18:D37").Copy
'Assign the sheet name to a variable
CurrentSheetName = ActiveSheet.Name
'Open the target workbook
Workbooks("Pay Verification2.xls").Activate
With Workbooks("Pay Verification2").Sheets("INPUT")
.Range("E65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
'Paste in the data
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
'Paste in the Job name (JobCode)
.Range("B65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
.Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
Selection.FormulaR1C1 = JobCode
'Paste in the sheet name
.Range("C65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
.Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
Selection.FormulaR1C1 = CurrentSheetName
CurrentSheetName = Null
'Extend the formulas down
.Range("D65536").End(xlUp).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
.Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
.Paste
.Range("H65536").End(xlUp).Select
Selection.Copy
ActiveCell.Offset(1, 0).Select
.Range(ActiveCell, ActiveCell.Offset(19, 0)).Select
.Paste
Application.CutCopyMode = False
.Range("A1").Select
End With

Workbooks(JobCode).Activate
Next sht
Workbooks("Pay Verification2.xls").Activate

Exit Sub

 

[Legacy 98055]

Change:

Selection.FormulaR1C1 = CurrentSheetName

To:

Selection.FormulaR1C1 = sht.Name

and/or

Change:

CurrentSheetName = ActiveSheet.Name

To:

CurrentSheetName = sht.Name
This message was edited by TsTom on 2002-04-28 22:47

 

[GeorgeB]

Aaaaaannnnnnnnd the MASTER has spoken and his word is like a thunderbolt from the mountain. You deserve to be elevated to
MVP for this.

HEAR THAT MR EXCEL

My gratitude knows no bounds. I will be the office hero thanks to you Tom.
Have a great evening. ("Whats left of it)