The goal of this script is to grab information on one spreadsheet, organise it and paste it into another spreadsheet, ready to import into a database AND to make it user friendly so that anyone in the company can do this (difficult, i know...)
Doing this manually takes a long time for there are hundreds of lines in the excel file. Copy and paste doesnt work all that well because some of the fields need to be manipulated.
I have spent hours and hours on this script and im very happy with the results. The script also hunts for the information in the right spreadsheet and the right column. The one field that remains the same all the time is the "Run#" column. SOOOO the script hunts for that cell, takes note on which sheet, row and column it is in, then checks the other fields to see if they are there.
Once it finds all the columns with the information needed, it then proceeds to copy the information and puts it into "paste.xml"
Now I have been through ALOT of testing and trialing this script to find out what problems could occur, and beleive me i have found many. solving those problems has caused the script to tripple in size.
One of the major problems is that sometimes the data doesnt paste (IT IS USING MICROSOFTS CLIPBOARD). Because of this I had to put in a loop that will check the cell that is being pasted to, and if it contains the same data from the source excel, then it proceeds. if it doesnt, then it loops, tries again.
I could go on and on about the many problems i have come up across, but i do beleive this script is very robust. I do beleive if i keep testing it, i will find more problems. So instead, here is the script:
'OPEN FILE PROCESS
Msgbox "Please select the file to process", 64
Const msoFileDialogOpen = 1
Set fso = CreateObject("Scripting.FileSystemObject")
Set objWord = CreateObject("Word.Application")
Set WshShell = CreateObject("WScript.Shell")
strInitialPath = WshShell.ExpandEnvironmentStrings("C:\")
objWord.ChangeFileOpenDirectory(strInitialPath)
With objWord.FileDialog(msoFileDialogOpen)
.Title = "Select the file to process"
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel Files", "*.xls;*.xlsx;*.csv"
If .Show = -1 Then
For Each File in .SelectedItems
Set objFile = fso.GetFile(File)
Next
Else
End if
End with
' IF USER SELECTS CANCEL, STOP SCRIPT
if objFile = "" then
objWord.Quit
wscript.quit
end if
source = objFile.Path
objWord.Quit
on error resume next
' IF FOUND VALUE IS 2, IT MEANS RUN# IS FOUND. SET THE FIND VALUE TO 1 WHICH MEANS NOT FOUND
found = 1
'How is vbs going to use excel copy (method)
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = false
objExcel.DisplayAlerts = false
'open copy.xls
Set objWorkbook = objExcel.Workbooks.Open(source)
'COUNT HOW MANY SHEETS IT HAS
sheetcount = objWorkbook.Worksheets.Count
sheetcount = sheetcount + 1
'COLUMN VALUE START FIND
column = "E"
'loop until it findS the RUN#
Do
'CURRENT SHEET
sheetnumber = sheetnumber + 1
'ONE IT CHECKS ALL 5 ROWS IN EACH SHEET, CHANGE TO A DIFFERENT COLUMN
if sheetnumber = sheetcount then
'resets which sheet to look at
sheetnumber = 1
'change which column to look at
colnumber = colnumber + 1
if colnumber = 1 then
column = "A"
end if
if colnumber = 2 then
column = "B"
end if
if colnumber = 3 then
column = "C"
end if
if colnumber = 4 then
column = "D"
end if
if colnumber = 5 then
column = "F"
end if
if colnumber = 6 then
column = "G"
end if
if colnumber = 7 then
column = "H"
end if
if colnumber = 8 then
column = "I"
end if
if colnumber = 9 then
column = "J"
end if
if colnumber = 10 then
column = "k"
end if
if colnumber = 11 then
column = "L"
end if
if colnumber = 12 then
column = "m"
end if
if colnumber = 13 then
column = "n"
end if
if colnumber = 14 then
column = "o"
end if
if colnumber = 15 then
column = "P"
end if
if colnumber = 16 then
column = "Q"
end if
if colnumber = 17 then
column = "R"
end if
if colnumber = 18 then
column = "S"
end if
if colnumber = 19 then
column = "T"
end if
if colnumber = 20 then
column = "U"
end if
if colnumber = 21 then
column = "V"
end if
if colnumber = 22 then
column = "W"
end if
if colnumber = 23 then
column = "X"
end if
if colnumber = 24 then
column = "Y"
end if
'cant find run? set to notify user and quit
if colnumber = 25 then
if found = 1 then
MSGBOX "Unable to find the run# column in the entire file", 16
objWorkbook.close
wscript.quit
end if
end if
End if
'loop through each row until finds run#
Do
rownumber = rownumber + 1
sheetcheck = 1
Set objWorksheet = objWorkbook.Worksheets(sheetnumber)
set sheetcheck = objWorksheet.Range(column & rownumber)
sheetcheck = Mid(sheetcheck,1,4)
sheetcheck = LCase(sheetcheck)
if sheetcheck = "run#" then
linecurrent = rownumber
'for fields that need pasting in all rows, use the following value as the start row
firstline = rownumber
sheet = sheetnumber
found = found + 1
fcolumn = column
if sheetcheck = "" then
MSGBOX "ERROR: Value in column " & column & ", row " & rownumber & " must be character data and not excel reference formulas", 16
objExcel.quit
wscript.quit
End If
end if
'change the value of searched cell so it doesnt return run# value again
sheetcheck = 1
loop until rownumber = 5
'once all rows have been searched in each column of all sheets, reset to start looking from row1
rownumber = 0
loop until colnumber = 25
if found > 2 then
Msgbox "More then one run# columns of data was found. Please Check the excel file.", 16
objWorkbook.close
wscript.quit
end if
msgbox "found the run section in sheet " & sheet & ", " & fColumn & " " & linecurrent, 64
'count total number of lines
objExcel.WorkSheets(sheet).Select
objExcel.ActiveSheet.UsedRange.Select
rc = objExcel.Selection.Rows.Count
'format last line as a number and add 1
lastline = rc + 1 - 1
'How is vbs going to use excel paste (method)
Set objExcel2 = CreateObject("Excel.Application")
objExcel2.Visible = True
'open paste.xls
Set objWorkbook2 = objExcel2.Workbooks.Open("C:\excelproject\paste.xls")
Set objWorksheet2 = objWorkbook2.Worksheets(1)
'start from row 1, ready to paste
pastenumber = 1
'check the Order fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("G" & linecurrent)
fieldcheck = Mid(fieldcheck,1,5)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "order" then
runtest = 2
Else
Msgbox "Could not find the Order section in the G column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Member fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("H" & linecurrent)
fieldcheck = Mid(fieldcheck,1,7)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "member#" then
runtest = 2
Else
Msgbox "Could not find the Member# section in the H column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Customer Name fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("I" & linecurrent)
fieldcheck = Mid(fieldcheck,1,13)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "customer name" then
runtest = 2
Else
Msgbox "Could not find the Customer Name section in the I column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Address1 fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("J" & linecurrent)
fieldcheck = Mid(fieldcheck,1,8)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "address1" then
runtest = 2
Else
Msgbox "Could not find the Address1 section in the J column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Address2 field and notify user if incorrect
Set fieldcheck = objWorksheet.Range("K" & linecurrent)
fieldcheck = Mid(fieldcheck,1,8)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "address2" then
runtest = 2
Else
Msgbox "Could not find the Address2 section in the k column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Suburb fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("L" & linecurrent)
fieldcheck = Mid(fieldcheck,1,6)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "suburb" then
runtest = 2
Else
Msgbox "Could not find the Suburb section in the J column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the State fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("N" & linecurrent)
fieldcheck = Mid(fieldcheck,1,5)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "state" then
runtest = 2
Else
Msgbox "Could not find the State section in the N column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Postcode fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("M" & linecurrent)
fieldcheck = Mid(fieldcheck,1,8)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "postcode" then
runtest = 2
Else
Msgbox "Could not find the Postcode section in the M column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Box Code fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("S" & linecurrent)
fieldcheck = Mid(fieldcheck,1,8)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "box code" then
runtest = 2
Else
Msgbox "Could not find the Box Code section in the S column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Phone3 fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("Q" & linecurrent)
fieldcheck = Mid(fieldcheck,1,6)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "phone3" then
runtest = 2
Else
Msgbox "Could not find the Phone3 section in the Q column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Phone2 fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("P" & linecurrent)
fieldcheck = Mid(fieldcheck,1,6)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "phone2" then
runtest = 2
Else
Msgbox "Could not find the Phone2 section in the P column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
'check the Phone1 fields and notify user if incorrect
Set fieldcheck = objWorksheet.Range("O" & linecurrent)
fieldcheck = Mid(fieldcheck,1,6)
fieldcheck = LCase(fieldcheck)
if fieldcheck = "phone1" then
runtest = 2
Else
Msgbox "Could not find the Phone1 section in the O column of sheet " & sheet & ", script will stop", 64
objExcel2.Quit
objWorkbook.close
wscript.quit
end if
totalruns = inputbox("How many runs would you like to do?")
'if user clicks cancel or no input, quit script and excel
if totalruns = "" then
objWorkbook.close
objExcel2.Quit
wscript.quit
end if
'format amount of runs as a number
totalruns = totalruns - 1 + 1
' begin loop to paste
Do
'loop count
ends = ends + 1
runnumask = inputbox("What is the run number?")
'if user clicks cancel or no input, quit script and excel
if runnumask = "" then
objWorkbook.close
objExcel2.Quit
wscript.quit
end if
runnumber = runnumask - 1 + 1
linecurrent = 0
Do
linecurrent = linecurrent + 1
'tell vbs which field to copy from
Set runcheck = objWorksheet.Range("E" & linecurrent)
'check run number
if runcheck = runnumber then
'tell vbs which line to paste to
pastenumber = pastenumber + 1
' COPY RUN NUMBER
Do
'tell vbs which field to copy from
Set OJobRef = objWorksheet.Range(fColumn & linecurrent)
OJobRef.Copy
'tell vbs which fields to past in
objWorksheet2.Range("D" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
'check the paste field, did it go in the cell?
set valcheck = objWorksheet2.Range("D" & pastenumber)
loop until valcheck = OJobRef
'PASTE SECOND RUN NUMBER INTO 'OCusRef' column
Do
objWorksheet2.Range("C" & pastenumber).Activate
objWorksheet2.paste
'check the paste field, did it go in the cell?
set valcheck = objWorksheet2.Range("C" & pastenumber)
loop until valcheck = OJobRef
' COPY MConNoteNo
do
'tell vbs which field to copy from
Set Mcon1 = objWorksheet.Range("G" & linecurrent)
Set Mcon2 = objWorksheet.Range("H" & linecurrent)
MconNoteNo = Mcon2 & Mcon1
'tell vbs which field to put the end value
objWorksheet2.Range("E" & pastenumber).Activate
objWorksheet2.Range("E" & pastenumber) = MconNoteNo
set valcheck = objWorksheet2.Range("E" & pastenumber)
MconNoteNo = FormatNumber(MconNoteNo)
valcheck = FormatNumber(valcheck)
lopcount = lopcount + 1
if lopcount = 10 then
MSGBOX "Unable to copy the G" & linecurrent & " and H" & linecurrent & " cells." & vbnewline & vbnewline & "Please check these cells in the source Excel and make sure the format is set to data", 32
wscript.quit
end if
loop until valcheck = MconNoteNo
lopcount = 0
' COPY MRecieverName
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("I" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("F" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("F" & pastenumber)
loop until valcheck = Reciever
' COPY MRecieverAddress
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("J" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("G" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("G" & pastenumber)
loop until valcheck = Reciever
' COPY ORecieverAddress1
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("K" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("H" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("H" & pastenumber)
loop until valcheck = Reciever
' COPY MRecieverSuburb
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("L" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("I" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("I" & pastenumber)
loop until valcheck = Reciever
' COPY MRecieverState
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("N" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("J" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("J" & pastenumber)
loop until valcheck = Reciever
' COPY MRecieverPcode
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("M" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("K" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("K" & pastenumber)
loop until valcheck = Reciever
' COPY MProduct
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("S" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("L" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("L" & pastenumber)
loop until valcheck = Reciever
' COPY Instructions
do
'tell vbs which field to copy from
Set Reciever = objWorksheet.Range("R" & linecurrent)
Reciever.Copy
'tell vbs which fields to past in
objWorksheet2.Range("O" & pastenumber).Activate
'paste what is in the clipboard
objWorksheet2.paste
set valcheck = objWorksheet2.Range("O" & pastenumber)
loop until valcheck = Reciever
' COPY oPhone
do
Set Ophone = objWorksheet.Range("Q" & linecurrent)
TestMob = Mid(Ophone,3,1)
If TestMob = 4 then
Set Ophone = objWorksheet.Range("Q" & linecurrent)
end if
If testmob <> 4 then
Set Ophone = objWorksheet.Range("P" & linecurrent)
TestMob = Mid(Ophone,3,1)
If testmob = 4 then
Set Ophone = objWorksheet.Range("P" & linecurrent)
End if
If testmob <> 4 then
Set Ophone = objWorksheet.Range("O" & linecurrent)
End if
End IF
Ophone.copy
objWorksheet2.Range("N" & pastenumber).Activate
objWorksheet2.paste
set valcheck = objWorksheet2.Range("N" & pastenumber)
loop until valcheck = Ophone
end if
loop until linecurrent = lastline
loop until ends = totalruns
objWorksheet2.Range("A2:A" & lastline).Activate
objWorksheet2.Range("A2:A" & lastline) = "CHRISCO"
objWorksheet2.Range("M2:M" & lastline).Activate
objWorksheet2.Range("M2:M" & lastline) = "1"
Msgbox "Complete", 64
objWorkbook.close