PDA

View Full Version : VBA: Apply loop to existing code



RedAxon
12-15-2016, 03:36 AM
Greetings,

I have the below code working as intended, however the amount of items I need to apply this code to has increased from a handful to several hundred. So I would like to apply a loop to the following code so that it goes through every excel document in the folder and performs the task:


Sub InspectionSheetTransfer()
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim vFile As Variant

'Set source workbook
Set wbSource = ActiveWorkbook

'Open the source workbook
vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
1, "Select One File To Open", , False)

'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile

'Set selectedworkbook
Set wbTarget = ActiveWorkbook

'transfer values
'Tag Number
wbSource.Sheets("Sheet1").Range("A2").Value = wbTarget.Sheets("Insp. Sheet").Range("M8")
'Location
wbSource.Sheets("Sheet1").Range("C2").Value = wbTarget.Sheets("Insp. Sheet").Range("T8")

'Equipment Description
wbSource.Sheets("Sheet1").Range("E2").Value = wbTarget.Sheets("Insp. Sheet").Range("C10")

'Manufacturer
wbSource.Sheets("Sheet1").Range("J2").Value = wbTarget.Sheets("Insp. Sheet").Range("I10")

'Model
wbSource.Sheets("Sheet1").Range("K2").Value = wbTarget.Sheets("Insp. Sheet").Range("P10")

'Serial Number
wbSource.Sheets("Sheet1").Range("L2").Value = wbTarget.Sheets("Insp. Sheet").Range("M8")

'Cable Reference
wbSource.Sheets("Sheet1").Range("M2").Value = wbTarget.Sheets("Insp. Sheet").Range("C12")

'Ex Protection
wbSource.Sheets("Sheet1").Range("O2").Value = wbTarget.Sheets("Insp. Sheet").Range("H12")

'Gas Group
wbSource.Sheets("Sheet1").Range("P2").Value = wbTarget.Sheets("Insp. Sheet").Range("L12")

'T Rating
wbSource.Sheets("Sheet1").Range("Q2").Value = wbTarget.Sheets("Insp. Sheet").Range("O12")

'IP Rating
wbSource.Sheets("Sheet1").Range("R2").Value = wbTarget.Sheets("Insp. Sheet").Range("R12")

'Cert Number
wbSource.Sheets("Sheet1").Range("S2").Value = wbTarget.Sheets("Insp. Sheet").Range("U12")

'Drawing Number
wbSource.Sheets("Sheet1").Range("T2").Value = wbTarget.Sheets("Insp. Sheet").Range("C14")

'Grid Ref
wbSource.Sheets("Sheet1").Range("U2").Value = wbTarget.Sheets("Insp. Sheet").Range("I14")

'Area Class
wbSource.Sheets("Sheet1").Range("W2").Value = wbTarget.Sheets("Insp. Sheet").Range("L14")

'Cert Auth
wbSource.Sheets("Sheet1").Range("X2").Value = wbTarget.Sheets("Insp. Sheet").Range("O14")

'Access Normal
wbSource.Sheets("Sheet1").Range("AE2").Value = wbTarget.Sheets("Insp. Sheet").Range("I15")

'Access Ladder
wbSource.Sheets("Sheet1").Range("AF2").Value = wbTarget.Sheets("Insp. Sheet").Range("M15")

'Access Scaffold
wbSource.Sheets("Sheet1").Range("AG2").Value = wbTarget.Sheets("Insp. Sheet").Range("Q15")

'Access Ropes
wbSource.Sheets("Sheet1").Range("AH2").Value = wbTarget.Sheets("Insp. Sheet").Range("U15")

'Access Overside
wbSource.Sheets("Sheet1").Range("AI2").Value = wbTarget.Sheets("Insp. Sheet").Range("Y15")

'Area Class 0
wbSource.Sheets("Sheet1").Range("AK2").Value = wbTarget.Sheets("Insp. Sheet").Range("F17")

'Area Class 1
wbSource.Sheets("Sheet1").Range("AL2").Value = wbTarget.Sheets("Insp. Sheet").Range("F18")

'Area Class 2
wbSource.Sheets("Sheet1").Range("AM2").Value = wbTarget.Sheets("Insp. Sheet").Range("F19")

'Area Class Safe
wbSource.Sheets("Sheet1").Range("AN2").Value = wbTarget.Sheets("Insp. Sheet").Range("F20")

'Ignition Risk H
wbSource.Sheets("Sheet1").Range("AP2").Value = wbTarget.Sheets("Insp. Sheet").Range("J17")

'Ignition Risk m
wbSource.Sheets("Sheet1").Range("AQ2").Value = wbTarget.Sheets("Insp. Sheet").Range("J18")

'Ignition Risk L
wbSource.Sheets("Sheet1").Range("AR2").Value = wbTarget.Sheets("Insp. Sheet").Range("J19")

'Enviroment S
wbSource.Sheets("Sheet1").Range("AT2").Value = wbTarget.Sheets("Insp. Sheet").Range("N17")

'Enviroment m
wbSource.Sheets("Sheet1").Range("AU2").Value = wbTarget.Sheets("Insp. Sheet").Range("N18")

'Enviroment b
wbSource.Sheets("Sheet1").Range("AV2").Value = wbTarget.Sheets("Insp. Sheet").Range("N19")

'corrosion h
wbSource.Sheets("Sheet1").Range("AX2").Value = wbTarget.Sheets("Insp. Sheet").Range("R17")

'corrosion m
wbSource.Sheets("Sheet1").Range("AY2").Value = wbTarget.Sheets("Insp. Sheet").Range("R18")

'corrosion l
wbSource.Sheets("Sheet1").Range("AZ2").Value = wbTarget.Sheets("Insp. Sheet").Range("R19")

'vibration h
wbSource.Sheets("Sheet1").Range("BB2").Value = wbTarget.Sheets("Insp. Sheet").Range("V17")

'vibration m
wbSource.Sheets("Sheet1").Range("BC2").Value = wbTarget.Sheets("Insp. Sheet").Range("V18")

'vibration l
wbSource.Sheets("Sheet1").Range("BD2").Value = wbTarget.Sheets("Insp. Sheet").Range("V19")

'inspection date
wbSource.Sheets("Sheet1").Range("BF2").Value = wbTarget.Sheets("Insp. Sheet").Range("L151")

'grade of inspection
wbSource.Sheets("Sheet1").Range("BG2").Value = wbTarget.Sheets("Insp. Sheet").Range("W24")

'inspected by
wbSource.Sheets("Sheet1").Range("BJ2").Value = wbTarget.Sheets("Insp. Sheet").Range("L154")



'close inspection sheet
wbTarget.Close

End Sub


In addition to applying the loop, the ability for the macro to enter a new line above once finished would be essentially (i.e, move the just completed line down 1)

Thank you very much for taking the time to read this, I look forward to your reply.

xld
12-15-2016, 05:55 AM
This will open a number of files and copy across, but each one will overwrite the previous, so if you want something else to happen, presumably you do, you need to say what, different ranges, different sheets?


Sub InspectionSheetTransfer()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim vFile As Variant

'Set source workbook
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets("Sheet1")

With Application.FileDialog(msoFileDialogOpen)

.AllowMultiSelect = True
.Filters.Add "Excel-files", "*.xlsx", 1
.Title = "Select One File To Open"

If .Show = 0 - 1 Then

'Set selectedworkbooks
Set wbTarget = ActiveWorkbook
Set wsTarget = wbTarget.Sheets("Insp. Sheet")

'transfer values
With wsTarget

'Tag Number
wsSource.Range("A2").Value = wbTarget.Range("M8")

'Location
wsSource.Range("C2").Value = .Range("T8")

'Equipment Description
wsSource.Range("E2").Value = .Range("C10")

'Manufacturer
wsSource.Range("J2").Value = .Range("I10")

'Model
wsSource.Range("K2").Value = .Range("P10")

'Serial Number
wsSource.Range("L2").Value = .Range("M8")

'Cable Reference
wsSource.Range("M2").Value = .Range("C12")

'Ex Protection
wsSource.Range("O2").Value = .Range("H12")

'Gas Group
wsSource.Range("P2").Value = .Range("L12")

'T Rating
wsSource.Range("Q2").Value = .Range("O12")

'IP Rating
wsSource.Range("R2").Value = .Range("R12")

'Cert Number
wsSource.Range("S2").Value = .Range("U12")

'Drawing Number
wsSource.Range("T2").Value = .Range("C14")

'Grid Ref
wsSource.Range("U2").Value = .Range("I14")

'Area Class
wsSource.Range("W2").Value = .Range("L14")

'Cert Auth
wsSource.Range("X2").Value = .Range("O14")

'Access Normal
wsSource.Range("AE2").Value = .Range("I15")

'Access Ladder
wsSource.Range("AF2").Value = .Range("M15")

'Access Scaffold
wsSource.Range("AG2").Value = .Range("Q15")

'Access Ropes
wsSource.Range("AH2").Value = .Range("U15")

'Access Overside
wsSource.Range("AI2").Value = .Range("Y15")

'Area Class 0
wsSource.Range("AK2").Value = .Range("F17")

'Area Class 1
wsSource.Range("AL2").Value = .Range("F18")

'Area Class 2
wsSource.Range("AM2").Value = .Range("F19")

'Area Class Safe
wsSource.Range("AN2").Value = .Range("F20")

'Ignition Risk H
wsSource.Range("AP2").Value = .Range("J17")

'Ignition Risk m
wsSource.Range("AQ2").Value = .Range("J18")

'Ignition Risk L
wsSource.Range("AR2").Value = .Range("J19")

'Enviroment S
wsSource.Range("AT2").Value = .Range("N17")

'Enviroment m
wsSource.Range("AU2").Value = .Range("N18")

'Enviroment b
wsSource.Range("AV2").Value = .Range("N19")

'corrosion h
wsSource.Range("AX2").Value = .Range("R17")

'corrosion m
wsSource.Range("AY2").Value = .Range("R18")

'corrosion l
wsSource.Range("AZ2").Value = .Range("R19")

'vibration h
wsSource.Range("BB2").Value = .Range("V17")

'vibration m
wsSource.Range("BC2").Value = .Range("V18")

'vibration l
wsSource.Range("BD2").Value = .Range("V19")

'inspection date
wsSource.Range("BF2").Value = .Range("L151")

'grade of inspection
wsSource.Range("BG2").Value = .Range("W24")

'inspected by
wsSource.Range("BJ2").Value = .Range("L154")
End With

'close inspection sheet
wbTarget.Close
End If
End With
End Sub

RedAxon
12-15-2016, 06:24 AM
Hi xld,

That looks great, I'll be able to add a few lines to make enter a row in excel after each excel document is finished.

Although, I'm getting a Run-time error 9: Subscript out of range on the following:


Set wsTarget = wbTarget.Sheets("Insp. Sheet")

xld
12-15-2016, 06:57 AM
That suggests that there is no worksheet called 'Insp. Sheet' in the target workbook.

xld
12-15-2016, 07:02 AM
Sorry, just realised I missed an important bit


Sub InspectionSheetTransfer()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wbTarget As Workbook
Dim wsTarget As Worksheet
Dim vFile As Variant
Dim i As Long

'Set source workbook
Set wbSource = ActiveWorkbook
Set wsSource = wbSource.Worksheets("Sheet1")

With Application.FileDialog(msoFileDialogOpen)

.AllowMultiSelect = True
.Filters.Add "Excel-files", "*.xlsx", 1
.Title = "Select All Files To Open"

If .Show = - 1 Then


For i = 1 To .SelectedItems.Count

'Set selectedworkbooks
Set wbTarget = Workbooks.Open(.SelectedItems(i))
Set wsTarget = wbTarget.Worksheets("Insp. Sheet")

'transfer values
With wsTarget

'Tag Number
wsSource.Range("A2").Value = .Range("M8")

'Location
wsSource.Range("C2").Value = .Range("T8")

'Equipment Description
wsSource.Range("E2").Value = .Range("C10")

'Manufacturer
wsSource.Range("J2").Value = .Range("I10")

'Model
wsSource.Range("K2").Value = .Range("P10")

'Serial Number
wsSource.Range("L2").Value = .Range("M8")

'Cable Reference
wsSource.Range("M2").Value = .Range("C12")

'Ex Protection
wsSource.Range("O2").Value = .Range("H12")

'Gas Group
wsSource.Range("P2").Value = .Range("L12")

'T Rating
wsSource.Range("Q2").Value = .Range("O12")

'IP Rating
wsSource.Range("R2").Value = .Range("R12")

'Cert Number
wsSource.Range("S2").Value = .Range("U12")

'Drawing Number
wsSource.Range("T2").Value = .Range("C14")

'Grid Ref
wsSource.Range("U2").Value = .Range("I14")

'Area Class
wsSource.Range("W2").Value = .Range("L14")

'Cert Auth
wsSource.Range("X2").Value = .Range("O14")

'Access Normal
wsSource.Range("AE2").Value = .Range("I15")

'Access Ladder
wsSource.Range("AF2").Value = .Range("M15")

'Access Scaffold
wsSource.Range("AG2").Value = .Range("Q15")

'Access Ropes
wsSource.Range("AH2").Value = .Range("U15")

'Access Overside
wsSource.Range("AI2").Value = .Range("Y15")

'Area Class 0
wsSource.Range("AK2").Value = .Range("F17")

'Area Class 1
wsSource.Range("AL2").Value = .Range("F18")

'Area Class 2
wsSource.Range("AM2").Value = .Range("F19")

'Area Class Safe
wsSource.Range("AN2").Value = .Range("F20")

'Ignition Risk H
wsSource.Range("AP2").Value = .Range("J17")

'Ignition Risk m
wsSource.Range("AQ2").Value = .Range("J18")

'Ignition Risk L
wsSource.Range("AR2").Value = .Range("J19")

'Enviroment S
wsSource.Range("AT2").Value = .Range("N17")

'Enviroment m
wsSource.Range("AU2").Value = .Range("N18")

'Enviroment b
wsSource.Range("AV2").Value = .Range("N19")

'corrosion h
wsSource.Range("AX2").Value = .Range("R17")

'corrosion m
wsSource.Range("AY2").Value = .Range("R18")

'corrosion l
wsSource.Range("AZ2").Value = .Range("R19")

'vibration h
wsSource.Range("BB2").Value = .Range("V17")

'vibration m
wsSource.Range("BC2").Value = .Range("V18")

'vibration l
wsSource.Range("BD2").Value = .Range("V19")

'inspection date
wsSource.Range("BF2").Value = .Range("L151")

'grade of inspection
wsSource.Range("BG2").Value = .Range("W24")

'inspected by
wsSource.Range("BJ2").Value = .Range("L154")
End With

'close inspection sheet
wbTarget.Close
Next i
End If
End With
End Sub

RedAxon
12-15-2016, 07:44 AM
Thanks again, one last thing...

Despite all my attempts, I can't quite work out how I would go about making a new row appear in wsSource after the copy/paste action for one sheet is completed.

I have tried using



'select sheet1 and create new line for next copy/paste
Sheets("Sheet1").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove


but it comes back with subscript out of range... Any suggestions?

xld
12-15-2016, 12:21 PM
If you are going to copy/paste each file to a new area, you will need a lot more than that, you have a whole raft of fields to copy over, and you would need to index all of the target cells. Is it your wish to copy file 1 to rows 20-100 (just an example, not necessarily the actual rows), file 2 to 120-200, file 3 to 220-300, and so on?