「Enheder」ワークシートの行数は10行程度で、データセットim loadinの行数は300行程度ですが、インポートしようとすると非常に長い時間がかかります。
Public Function ImportData()
Dim resultWorkbook As Workbook
Dim curWorkbook As Workbook
Dim importsheet As Worksheet
Dim debugsheet As Worksheet
Dim spgsheet As Worksheet
Dim totalposts As Integer
Dim year As String
Dim month As String
Dim week As String
Dim Hospital As String
Dim varType As String
Dim numrows As Integer
Dim Rng As Range
Dim colavg As String
Dim timer As String
Dim varKey As String
year = ImportWindow.ddYear.value
month = ImportWindow.ddMonth.value
week = "1"
varType = ImportWindow.ddType.value
Hospital = ImportWindow.txtHospital.value
Set debugsheet = ActiveWorkbook.Sheets("Data")
Set spgsheet = ActiveWorkbook.Sheets("Spørgsmål")
Set depsheet = ActiveWorkbook.Sheets("Enheder")
Set resultWorkbook = OpenWorkbook()
setResultColVars debugsheet
'set sheets
Set importsheet = resultWorkbook.Sheets("Dataset")
numrows = debugsheet.UsedRange.Rows.Count
'make sure that the enhed can be found in the importsheet, so the units can be extracted accordingly
If Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
Dim DepColumn
Dim aCell
DepColumn = importsheet.UsedRange.Find("afdeling").column
'sort importsheet to allow meaningfull row calculations
Set aCell = importsheet.UsedRange.Columns(DepColumn)
importsheet.UsedRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Dim tempRange As Range
Dim SecColumn
Dim secRange As Range
'find row ranges for departments
Application.ScreenUpdating = False
'**Here's the loop that will go on for aaaaaages until I decide to ctrl+pause**
For Each c In depsheet.UsedRange.Columns(1).Cells
splStr = Split(c.value, "_")
If UBound(splStr) = -1 Then
ElseIf UBound(splStr) = 0 Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, DepColumn, splStr(0)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), 0, varType, False)
ElseIf UBound(splStr) = 1 And Not (importsheet.UsedRange.Find("afdeling_" & splStr(0)) Is Nothing) Then
totalposts = totalposts + IterateColumns(GetRowRange(importsheet, importsheet.UsedRange.Find("afdeling_" & splStr(0)).column, splStr(1)), spgsheet, importsheet, debugsheet, year, month, week, Hospital, splStr(0), splStr(1), varType, False)
End If
Next
Application.ScreenUpdating = True
' go through columns to get total scores
totalposts = totalposts + IterateColumns(importsheet.UsedRange, spgsheet, importsheet, debugsheet, year, month, week, Hospital, 0, 0, varType, True)
resultWorkbook.Close Saved = True
ResultsWindow.lblPoster.Caption = totalposts
ImportWindow.Hide
ResultsWindow.Show
Else
MsgBox "Kunne ikke finde afdelingskolonnen. Kontroller at der er er en kolonne med navnet 'afdeling' i dit datasæt"
End If
End Function
Function GetRowRange(sheetRange, column, value) As Range
'check for a valid section column
sheetRange.AutoFilterMode = False
sheetRange.UsedRange.AutoFilter Field:=column, Criteria1:=value
Set GetRowRange = sheetRange.UsedRange.SpecialCells(xlCellTypeVisible)
sheetRange.AutoFilterMode = False
End Function
'iterates through columns of a range to get the averages based on the column headers
Function IterateColumns(varRange As Range, spgsheet, importsheet, resultsheet, year, month, week, Hospital, dep, sec, varType, sortspg As Boolean)
Dim numrows
Dim totalposts
Dim usedRng
totalposts = 0
numrows = resultsheet.UsedRange.Rows.Count
Dim insert
insert = True
If Not (varRange Is Nothing) Then
' go through columns to get scores
For i = 1 To varRange.Columns.Count
Dim tempi
tempi = numrows + totalposts + 1
Set Rng = varRange.Columns(i)
With Application.WorksheetFunction
'make sure that the values can calculate
If (.CountIf(Rng, "<3") > 0) Then
colavg = .SumIf(Rng, "<3") / .CountIf(Rng, "<3")
insert = True
Else
insert = False
End If
End With
'key is the variable
varKey = importsheet.Cells(1, i)
'only add datarow if the data matches a spg, and the datarow is not actually a department
If (sortSpgs(varKey, spgsheet, sortspg)) And (insert) And Not (InStr(key, "afdeling")) Then
resultsheet.Cells(tempi, WyearCol).value = year
resultsheet.Cells(tempi, WmonthCol).value = month
resultsheet.Cells(tempi, WweekCol).value = "1"
resultsheet.Cells(tempi, WhospCol).value = "Newport Hospital"
resultsheet.Cells(tempi, WdepCol).value = "=VLOOKUP(N" & tempi & ",Enheder!$A:$B,2,0)"
resultsheet.Cells(tempi, WsecCol).value = "=IFERROR(VLOOKUP(O" & tempi & ",Enheder!$A:$B,2,0),"" "")"
resultsheet.Cells(tempi, WdepnrCol).value = dep
resultsheet.Cells(tempi, WsecnrCol).value = dep & "_" & sec
resultsheet.Cells(tempi, WjtypeCol).value = varType
resultsheet.Cells(tempi, WspgCol).value = varKey
resultsheet.Cells(tempi, WsporgCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,6,0)"
resultsheet.Cells(tempi, WtestCol).value = ""
resultsheet.Cells(tempi, Wsv1Col).value = colavg
resultsheet.Cells(tempi, Wsv2Col).value = (1 - colavg)
resultsheet.Cells(tempi, Wsv3Col).value = ""
resultsheet.Cells(tempi, WgrpCol).value = "=VLOOKUP(H" & tempi & ",Spørgsmål!$D:$I,4,0)"
totalposts = totalposts + 1
End If
Next
End If
IterateColumns = totalposts
End Function
'Function that gets the workbook for import
Function OpenWorkbook()
Dim pathString As String
Dim resultWorkbook As Workbook
pathString = Application.GetOpenFilename(fileFilter:="All Files (*.*), *.*")
' check if it's already opened
For Each wb In Workbooks
If InStr(pathString, wb.Name) > 0 Then
Set resultWorkbook = wb
Exit For
End If
Next wb
If Not found Then
Set resultWorkbook = Workbooks.Open(pathString)
End If
Set OpenWorkbook = resultWorkbook
End Function
'find column numbers for resultsheet instead of having to do this in every insert
Function setResultColVars(rsheet)
WyearCol = rsheet.UsedRange.Find("År").column
WmonthCol = rsheet.UsedRange.Find("Måned").column
WweekCol = rsheet.UsedRange.Find("Uge").column
WhospCol = rsheet.UsedRange.Find("Hospital").column
WdepCol = rsheet.UsedRange.Find("Afdeling").column
WsecCol = rsheet.UsedRange.Find("Afsnit").column
WdepnrCol = rsheet.UsedRange.Find("Afdelingsnr").column
WsecnrCol = rsheet.UsedRange.Find("Afsnitnr").column
WjtypeCol = rsheet.UsedRange.Find("Journaltype").column
WspgCol = rsheet.UsedRange.Find("spg").column
WsporgCol = rsheet.UsedRange.Find("spørgsmål").column
WtestCol = rsheet.UsedRange.Find("test").column
Wsv1Col = rsheet.UsedRange.Find("Svar 1").column
Wsv2Col = rsheet.UsedRange.Find("Svar 0").column
Wsv3Col = rsheet.UsedRange.Find("Svar 3").column
WgrpCol = rsheet.UsedRange.Find("Gruppering").column
End Function
Function sortSpgs(key, sheet, sortspg As Boolean)
If Not (sheet.UsedRange.Find(key) Is Nothing) Then
If (sortspg) Then
ResultsWindow.lstGenkendt.AddItem key
End If
sortSpgs = True
Else
If (sortspg) Then
ResultsWindow.lstUgenkendt.AddItem key
End If
sortSpgs = False
End If
End Function
Function Progress()
iProgress = iProgress + 1
Application.StatusBar = iProgress & "% Completed"
End Function