Extract specified data from multiple request forms to another excel workbook

jenovauh

New Member
Joined
Mar 21, 2011
Messages
6
Hi everyone, I am new with vbs and trying to seek help from the expert here.
I have lots of request forms data to be extracted from a specified folder (c:\Data\) into a new workbook (c:\Data\Complete\Data.xls).
Been working on it for the passed 2 week and still didnt manage to get the result i wanted.

Result that i am trying to achieve:
1: To extract specify data from specified folder which contains all the request excel forms into 1 workbook.
2: Error checking when specify data is empty and will append as "Blank" in the table.
3: To ensure new data will not be overwrite when extracting new data into table.

Below is the code i have been working on, hope that someone can enlighten me. Thanks everyone.

Code:
Sub test()

Dim xRng As Range, yRng As Range
Dim arrLog As Variant
Dim iRow As Long
Dim i As Long
Dim ws As Worksheet
Set ws = Worksheets("Wrong")

Application.ScreenUpdating = False

With Sheets("Form")
arrLog = Array("Staff ID", "Staff Name", "Join Date", "End Date", _
"Contact No", "Email Address", "Grade", "Position Title", _
"Entity", "Work Location", "Cost Centre Code", "*Fixed Salary*", _
"*Basic Salary*", "*Term of Offer*", "*Accomodation and others*")

'Find first empty row in database
iRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For i = LBound(arrLog) To UBound(arrLog)
Set xRng = .Range("A1:J34").Find(What:=arrLog(i), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Set xRng = Application.Intersect(xRng.Offset(0, 1), xRng.Parent.UsedRange)

'j for number of field to fill in to table database (Sheet2)
For j = 1 To 15
Set yRng = ws.Cells(Rows.Count, j).End(xlUp)
Set yRng = Range(yRng, yRng.Cells(1, xRng.Columns.Count))
yRng.Value = xRng.Value

'MsgBox arrLog(I) & " : " & xRng
'ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row.Paste
Next j
Next i
If Nothing Is xRng Then MsgBox "Nothing Found": Exit Sub
End With

Application.ScreenUpdating = True

End Sub

Table in another workbook:
<table border="0" cellpadding="0" cellspacing="0" width="960"><col span="15" width="64"><tbody><tr height="20"> <td class="xl73" style="height: 15pt; width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" height="20" width="64">Staff ID</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Staff Name </td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Join Date</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">End Date</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Contact No</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Email Address</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Grade</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Position Title</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Entity</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Work Location</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Cost Centre Code</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Fixed Salary</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Basic Salary</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">Term of Offer</td> <td class="xl73" style="width: 48pt; font-size: 11pt; color: white; font-weight: 700; text-decoration: none; font-family: Calibri; border: 0.5pt solid windowtext; background: none repeat scroll 0% 0% rgb(75, 172, 198);" width="64">ACCOMODATION AND OTHERS</td> </tr></tbody></table>
 

Excel Facts

Do you hate GETPIVOTDATA?
Prevent GETPIVOTDATA. Select inside a PivotTable. In the Analyze tab of the ribbon, open the dropown next to Options and turn it off

Forum statistics

Threads
1,222,068
Messages
6,163,726
Members
451,854
Latest member
Tiffany Smith

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top