Advertisement
Advertisement
| 06.12.2008 at 12:29PM PDT, ID: 23480799 |
|
[x]
Attachment Details
|
||
|
[x]
The Solution Rating System
|
||
With so many solutions, how can you tell which solutions are most likely to help you and which ones are not? To provide you with a tool to use, we rate our solutions based on various elements that most accurately determine if a solution is a quality solution. To explain what factors affect the solution rating, here are the elements we take into consideration when formulating our solution rating.
Your Input Matters If you have any suggestions that you would like to make for our rating system, please ask a question in the Suggestions Zone of Community Support. Thank you! |
||
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: |
Public Sub ExcelScan()
Dim xlApp As New Excel.Application
Dim xlWB As Excel.Workbook, xlWB2 As Excel.Workbook
Dim xlWS As Excel.Worksheet, xlWS2 As Excel.Worksheet
Dim xlRng As Excel.Range, xlRng1 As Excel.Range, xlRng2 As Excel.Range
Dim fso As New Scripting.FileSystemObject
Dim fl As File
Dim fls As Files
Dim fol As Folder
Dim q As Integer, v As Integer, w As Integer, x As Integer, y As Integer, z As Integer
'Source of raw NFTS Query output files xls
Const Filepath = "S:\NYC Reports\- Working Reports Folder\Inventory SWIP\Data_from_NFTS\Raw\"
'Location to save formatted NFTS data for importing to Access Database
Const Path2 = "S:\NYC Reports\- Working Reports Folder\Inventory SWIP\Data_from_NFTS\Ready\"
xlApp.Visible = False
Set xlWB2 = xlApp.Workbooks.Add
Set xlWS2 = xlWB2.Worksheets.Add
'Range for the column headers in the new sheet
Set xlRng1 = xlWS2.Range("A1", "J1")
'Need help here, I don't know how many rows I will end up with.
Set xlRng2 = xlWS2.Range("A2", "J1000") 'Need help here - destination range for the data to be copied
Set fol = fso.GetFolder(Filepath)
Set fls = fol.Files
'Set the Column Header Values in Columns A thu J
' reference format cells(row,column)
xlRng1.Cells(1, 1) = "SEC_CODE"
xlRng1.Cells(1, 2) = "DESC"
xlRng1.Cells(1, 3) = "RP_CODE"
xlRng1.Cells(1, 4) = "RP_DESC"
xlRng1.Cells(1, 5) = "FILE_NUMBER"
xlRng1.Cells(1, 6) = "RPC_ASSIGNED"
xlRng1.Cells(1, 7) = "LAST_ACTIVITY"
xlRng1.Cells(1, 8) = "LAST_AUDIT"
xlRng1.Cells(1, 9) = "STATUS"
xlRng1.Cells(1, 10) = "NFTS_DATE"
v = 1
For Each fl In fls
Set xlWB = xlApp.Workbooks.Open(fl, False, False)
Set xlWS = xlWB.Worksheets("RPT_VALFLIST.RPT")
'Count the number of rows in sheet
q = xlWS.Cells.Find(What:="*", LookIn:=-4163, LookAt:=1, SearchOrder:=1, SearchDirection:=2).Row
'I was going to use the value of q to set my range limit, but wasn't
' Sure how to do this, I got errors no matter what I tried.
'Does my current setting limit me to 10000 rows of data?
Set xlRng = xlWS.Range("A19", "J10000")
For z = 1 To q Step 1
If xlRng.Cells(z, 1) <> "" Then
xlRng2.Cells(v, 1) = xlRng.Cells(z, 1)
xlRng2.Cells(v, 2) = xlRng.Cells(z, 2).Value
xlRng2.Cells(v, 3) = xlRng.Cells(z, 3).Value
xlRng2.Cells(v, 4) = xlRng.Cells(z, 4).Value
xlRng2.Cells(v, 5) = xlRng.Cells(z, 5).Value
xlRng2.Cells(v, 6) = xlRng.Cells(z, 6).Value
xlRng2.Cells(v, 7) = xlRng.Cells(z, 7).Value
xlRng2.Cells(v, 8) = xlRng.Cells(z, 8).Value
xlRng2.Cells(v, 9) = xlRng.Cells(z, 9).Value
xlRng2.Cells(v, 10) = xlRng.Cells(10, 3).Value
v = v + 1
End If
Next z
Next fl
' go through each file, copy the data from A19:J___ (to the last row of data)
' Need to set Column J = to the value found on the source worksheet in cell = C12 (Date mm/dd/yyyy)
' Repeat this for each workbook in the folder - copying the data and appending it at the bottom of the
' destination sheet
Set xlRng = Nothing
Set xlWS = Nothing
xlApp.DisplayAlerts = False
xlWB2.SaveAs Path2 & "NFTS_Temp.xls"
xlApp.DisplayAlerts = True
Set xlRng = Nothing
Set xlRng2 = Nothing
Set xlWS2 = Nothing
Set xlWB = Nothing
Set xlWB2 = Nothing
xlApp.Quit
Set xlApp = Nothing
MsgBox "File created successfully: " & Path2 & "NFTS_Temp.xls", vbOKOnly, "File created"
End Sub
|