I'm very new to VBA programming and this is only me second user form database. I am trying to initialize combo boxes in a user form, but the data needs to be in 2 different sheets in the same work book. I have no issue when it needs to initialize from only one sheet, but cannot find a solution to use 2 sheets in the same form. The code below is what I currently have. What I need to do is move the first line data (Hengelaar List) to a separate sheet called "Lede Lys", but have no idea how to code this new sheet into the existing Private sub.
I really hope this makes sense.
Thanks in advance
Private Sub UserForm_Initialize()
With Worksheets("Reference sheet")
***Hengelaar.List = .Range("b2:b500").Value
Permitdatum.Value = Format(Date, "mm/dd/yyyy")***
Spesie1.List = .Range("A2:A17").Value
Spesie2.List = .Range("A2:A17").Value
Spesie3.List = .Range("A2:A17").Value
Spesie4.List = .Range("A2:A17").Value
Spesie5.List = .Range("A2:A17").Value
Spesie6.List = .Range("A2:A17").Value
Spesie7.List = .Range("A2:A17").Value
Spesie8.List = .Range("A2:A17").Value
Spesie9.List = .Range("A2:A17").Value
Spesie10.List = .Range("A2:A17").Value
TotalKilos.Value = ("")
Permitdatum.Value = ("")
End With
End Sub
Private Sub UserForm_Initialize()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Sheets(2).Range("A1:A3")
Set rng2 = Sheets(1).Range("A1:a3")
comboboxValue = _
Split(Join(Application.WorksheetFunction.Transpose(rng1.Value), ",") & "," _
& Join(Application.WorksheetFunction.Transpose(rng2.Value), ","), ",")
Me.ComboBox1.List = comboboxValue
End Sub
Related
So I have a form called "Print_Form" that has 20 checkboxes that upon form initialization take on the sheet names of the first 20 sheets of my workbook.
(no issue with the UserForm_Initialize() sub, this works fine)
Private Sub UserForm_Initialize()
CheckBox1.Caption = Sheets(1).Name
CheckBox2.Caption = Sheets(2).Name
CheckBox3.Caption = Sheets(3).Name
CheckBox4.Caption = Sheets(4).Name
CheckBox5.Caption = Sheets(5).Name
CheckBox6.Caption = Sheets(6).Name
CheckBox7.Caption = Sheets(7).Name
CheckBox8.Caption = Sheets(8).Name
CheckBox9.Caption = Sheets(9).Name
CheckBox10.Caption = Sheets(10).Name
CheckBox11.Caption = Sheets(11).Name
CheckBox12.Caption = Sheets(12).Name
CheckBox13.Caption = Sheets(13).Name
CheckBox14.Caption = Sheets(14).Name
CheckBox15.Caption = Sheets(15).Name
CheckBox16.Caption = Sheets(16).Name
CheckBox17.Caption = Sheets(17).Name
CheckBox18.Caption = Sheets(18).Name
CheckBox19.Caption = Sheets(19).Name
CheckBox20.Caption = Sheets(20).Name
End Sub
Where I am running into issues is in the following sub routine when the user clicks the print button in the form. The intention behind this button is to print all the sheets that the user has selected (i.e. the sheets that had their corresponding checkbox checked by the user). Currently, when I select multiple checkboxes and then click on the print button I get the following error; "Run-Time error '9': Subscript out of range.
Private Sub cmdPrint_Click()
Dim i As Integer
Dim cb As MSForms.Control
Dim SheetArray() As String
i = 0
'Search form for a checkbox
For Each cb In Me.Controls
i = i + 1
ReDim Preserve SheetArray(i)
'If the control is a checkbox
If TypeName(cb) = "CheckBox" Then
'and the checkbox is checked
If cb.Value = True Then
'Add the sheet to the sheet array (sheet name string was already added to the checkbox property caption; see UserForm_initialize)
SheetArray(i) = cb.Caption
End If
End If
Next cb
'Print Sheet Array
Sheets(SheetArray()).PrintOut
Unload Me
End Sub
If anyone has any ideas that would help me get this to work I would be very appreciative. Thank you in advance. :)
Try this:
Private Sub UserForm_Initialize()
Dim i As Long
For i = 1 To 20 'less typing....
Me.Controls("CheckBox" & i).Caption = Sheets(i).Name
Next i
End Sub
Private Sub cmdPrint_Click()
Dim i As Integer, s As String, sep
For i = 1 To 20
With Me.Controls("CheckBox" & i)
If .Value Then
s = s & sep & .Caption
sep = "," 'add delimiter after first item
End If
End With
Next i
Sheets(Split(s, ",")).PrintOut
Unload Me
End Sub
I have named a number of columns as ranges e.g.
DesCond1, DesDiff1, Comparison1, DesCond2, DesDiff2, Etc...
I have some buttons which use a macro to toggle the different columns visible or hidden. I have added the code I am using for one of these buttons.
Currently I have written the code to show or hide each range individually but I would like a code that will count the number of ranges with a similar name (DesCond1, DesCond2.. DesCond(n))and then loop through each one automatically checking the hidden status so I don't have to add to the code everytime I add more data. Here is my code so far. This works fine so far.
Sub ComparisonToggle1()
Dim ComparisonAll As Range, R_Cond As Range, R_Diff As Range
'set first of each range as identifier for decisions
Set R_Comp = Range("Comparison1")
'set all ranges under one name
Set CompAll = Union(Range("Comparison1"), Range("Comparison2"), Range("Comparison3")) 'name and add when new tests are added
If R_Comp.EntireColumn.Hidden = False Then 'False
CompAll.EntireColumn.Hidden = True 'hide all
ElseIf R_Comp.EntireColumn.Hidden = True Then 'True
CompAll.EntireColumn.Hidden = False 'vis all
End If
End Sub
Sub DesignToggle1()
Dim DesCondAll As Range, DesDiffAll As Range, R_Cond As Range, R_Diff As Range
'set first of each range as identifier for decisions
Set R_Cond = Range("DesCond1")
Set R_Diff = Range("DesDiff1")
'set all ranges under one name
Set DesCondAll = Union(Range("DesCond1"), Range("DesCond2"), Range("DesCond3"), Range("DesCond4"), Range("DesCond5"), Range("DesCond6")) 'name and add when new tests are added
Set DesDiffAll = Union(Range("DesDiff1"), Range("DesDiff2"), Range("DesDiff3"), Range("DesDiff4"), Range("DesDiff5"), Range("DesDiff6")) 'name and add when new tests are added
If R_Cond.EntireColumn.Hidden = False And R_Diff.EntireColumn.Hidden = False Then 'False/False
DesCondAll.EntireColumn.Hidden = True 'both hidden
DesDiffAll.EntireColumn.Hidden = True
ElseIf R_Cond.EntireColumn.Hidden = True And R_Diff.EntireColumn.Hidden = False Then 'True/False
DesCondAll.EntireColumn.Hidden = False 'vis both
DesDiffAll.EntireColumn.Hidden = False
ElseIf R_Cond.EntireColumn.Hidden = False And R_Diff.EntireColumn.Hidden = True Then 'False/True
DesCondAll.EntireColumn.Hidden = False 'vis both
DesDiffAll.EntireColumn.Hidden = False
ElseIf R_Cond.EntireColumn.Hidden = True And R_Diff.EntireColumn.Hidden = True Then 'True/True
DesCondAll.EntireColumn.Hidden = False 'vis both
DesDiffAll.EntireColumn.Hidden = False
End If
End Sub
This is to loop through all the names in your workbook, thought you need to give it the group you want to filter:
Option Explicit
Sub Test(Group As String)
Dim MyName As Name
For Each MyName In ThisWorkbook.Names
If MyName.Name Like "*" & Group & "*" Then
Range(MyName).EntireColumn.Hidden = True
End If
Next MyName
End Sub
Sub Main()
'This procedure calls the Test procedure feeding the variable Group as "Descond"
Test "Descond"
End Sub
I have a userform in which i am populating the data based on Unique ID's. I then want to give the users option to select the Unique ID through a Combo box. After that i want to populate the Company name pertaining to that Unique ID in the Text box. I am applying Vlookup for the same but it is giving me an error, "Unable to get the Vlookup property of the worksheet class function".
I have checked the values are there in the range but it is still giving me the same error.
Please help
Private Sub CBUniqueIDDSR_Change()
Me.TBParentCoDSR.Text =
Application.WorksheetFunction.VLookup(CBUniqueIDDSR.Value, Lookup_Range,
2, False)
End Sub
Private Sub UserForm_Initialize()
Application.Run "Before_Initializing"
Dim Lookup_Range As Range
sht2.Visible = True
sht3.Visible = True
Set Lookup_Range = sht3.Range("A:C")
With sht2
Me.CBMonth.List = .Range("X3", .Range("X3").End(xlDown)).Value
Me.CBCustomerCat.List = .Range("B3", .Range("B3").End(xlDown)).Value
Me.CBVertical.List = .Range("Y3", .Range("Y3").End(xlDown)).Value
Me.CBOperatingLocState.List = .Range("C3",
.Range("C3").End(xlDown)).Value
Me.CBDecisionMakingUnit.List = .Range("A3",
.Range("A3").End(xlDown)).Value
Me.CBRelationshipBuild.List = .Range("E3",
.Range("E3").End(xlDown)).Value
Me.CBGiftAllowed.List = .Range("F3", .Range("F3").End(xlDown)).Value
Me.CBDayDSR.List = .Range("I3", .Range("I3").End(xlDown)).Value
Me.CBMonthDSR.List = .Range("J3", .Range("J3").End(xlDown)).Value
Me.CBYearDSR.List = .Range("K3", .Range("K3").End(xlDown)).Value
End With
With sht3
Me.CBUniqueIDDSR.List = .Range("A2", .Range("A2").End(xlDown)).Value
End With
sht2.Visible = False
sht3.Visible = False
End Sub
Private Sub CBUniqueIDDSR_Change()
'If you Unique is in text format, use coding below
Me.TBParentCoDSR.Value = WorksheetFunction.VLookup(Me.CBUniqueIDDSR.Value, Worksheets("Sheet12").Range("A2:" & Range("B2").End(xlDown).Address), 2, False)
'If you Unique is in number format, use coding below
'Me.TBParentCoDSR.Value = WorksheetFunction.VLookup(Val(Me.CBUniqueIDDSR.Value), Worksheets("Sheet12").Range("A2:" & Range("B2").End(xlDown).Address), 2, False)
End Sub
Private Sub UserForm_Initialize()
For Each cell In Worksheets("Sheet12").Range("A2:" & Range("A2").End(xlDown).Address)
Me.CBUniqueIDDSR.AddItem cell.Value
Next
End Sub
I'm new to VBA. I have found code that copy and rename multiple template worksheets based on a list in a column (A1, A2, A3 etc). I tried modifying it to loop through a row instead, ie cells A1, B1, C1, D1, E1, but no luck. I want to copy multiple templates and rename them based on an account number entered via a user input form. I have created a worksheet, LedgerArray, that lists worksheet names for each account number. Example:
row1: 1Savings, 1Shares, 1Statement
row2: 2Savings, 2Shares, 2Statement
Thanks in advance
Hello Ambie, your effort is much appreciated, fluey infant especially. I developed the code below. It works as far as copying and renaming the templates, and assigning user input to specific template header cells. These tasks are intended for new accounts. A separate user form is intended for existing accounts. As you indicated, no error handling procedures are included (eg entry of a duplicate account number). Also, the section of the code that should transfer share transaction data to the first empty row in the renamed worksheet does not work. When executed, the code returns no syntax error but the result on the first empty row is blank.
Sub CommandButton1_Click()
Dim Template As String, str1 As String, str2 As String, str3 As String, str4 As String, str5 As String
Dim ws As Worksheet, lrShar As Long, lrSav As Long, lrTD As Long, lrStmnt As Long
str1 = "Shares"
str2 = "Savings"
str3 = "TimeDeposit"
str4 = "Loans"
str5 = "Statements"
'hide the form
frmAddSheet.Hide
'Select 1st template
Template = "TemplateShares"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str1
'Transfer Heading data
Set ws = Sheets(AccNumTextBox & str1)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'transfer Share transaction data
lrShar = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A" & lrShar).Value = DTPicker4.Value
ws.Range("B" & lrShar).Value = Reference.Value
ws.Range("C" & lrShar).Value = SharesTextBox.Value
'Select 2nd template
Template = "TemplateSavings"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str2
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str2)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'Select 3rd template
Template = "TemplateTimeDeposit"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str3
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str3)
ws.Range("A4") = AccNumTextBox.Value
ws.Range("B5") = DTPicker4.Value
ws.Range("B6") = Reference.Value
ws.Range("B7") = RegFeeTextBox.Value
ws.Range("B8") = NameTextBox.Value
ws.Range("B9") = AddressTextBox.Value
ws.Range("B10") = TelNumTextBox.Value
ws.Range("B11") = EmailTextBox.Value
ws.Range("B12") = ComboBox2.Value
ws.Range("B13") = DOBDTPicker.Value
'Select 4th template
Template = "TemplateLoans"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str4
'Select 5th template
Template = "TemplateStatement"
'copy template to create a new sheet
Sheets(Template).Select
Sheets(Template).Copy After:=Sheets(Sheets.Count)
'make the sheet visible in case the template is hidden
ActiveSheet.Visible = xlSheetVisible
'Rename the sheet
ActiveSheet.Name = AccNumTextBox & str5
'Transfer Heading data
Set ws = Worksheets(AccNumTextBox & str5)
ws.Range("B8") = AccNumTextBox.Value
ws.Range("B9") = DTPicker4.Value
ws.Range("B10") = NameTextBox.Value
'Bring Data Entry sheet back to front if necesary
If chkBringToFront = False Then
Sheets("DataEntry").Select
End If
End Sub
As you're new to VBA, I've given an example that uses some aspects you might find useful in your coding future (a class and a collection).
Create a new class and call it cTemplate. Add the following properties:
Public Original As Worksheet
Public Suffix As String
Declare this module-level variable (ie at the top of your programme).
Private mTemplateList As Collection
Populate a collection with your template objects. (Note I've done this in a routing called "Initialise". If you don't have something similar then just call this routine in your Workbook_Open event).
I'd prefer to keep control of the template names, so you'll see that I've added them manually. In response to your question though, I've put a routine below it that reads the first row of a worksheet and takes out the template name, but it has no error handling and if anything should change in that list, your entire worksheet naming structure will be messed up.
Sub Initialise()
'
' /.../
'
Dim template As cTemplate
' Populate the collection with template and clone names.
Set mTemplateList = New Collection
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateSavings")
template.Suffix = "Savings"
mTemplateList.Add template
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateShares")
template.Suffix = "Shares"
mTemplateList.Add template
Set template = New cTemplate
Set template.Original = ThisWorkbook.Worksheets("templateStatements")
template.Suffix = "Statements"
mTemplateList.Add template
'
' Or if you really must read a row of previous worksheet names
' and you are certain the first row contains "1" then sheet name,
' use the following
'
Dim rng As Range
Dim cell As Range
dim str as String
Set mTemplateList = New Collection
' Quick and nasty row 1 selection -
' Adjust as you require for your own rows.
Set rng = ThisWorkbook.Worksheets("Sheet1").UsedRange.Resize(1)
' Read each cell to obtain the template sheet name
' Assumes each name has "1" and "template" at the start
For Each cell In rng.Columns
Set template = New cTemplate
str = Replace(cell.Text, "1", "")
Set template.Original = ThisWorkbook.Worksheets(str)
str = Replace(str, "template", "")
template.Suffix = str
mTemplateList.Add template
Next
End Sub
And finally, when a user adds a new account number, call the following routine.
Sub CreateNewTemplates(accountNumber As Long)
Dim template As cTemplate
Dim accountPrefix As String
Dim lastSheet As Worksheet
' Create prefix for worksheet names
accountPrefix = Format(accountNumber, "00000")
' Loop through the templates to copy
Set lastSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
For Each template In mTemplateList
template.Original.Copy After:=lastSheet
ActiveSheet.Name = accountPrefix & template.Suffix
Set lastSheet = ActiveSheet
Next
End Sub
Worksheet objects need careful error handling and your routine will need to check for duplicate account names, missing templates, etc. The same applies to your row reader for worksheet names. I'm afraid I'm typing at night with a fluey infant on my lap and she's just stirring, so I'll leave that bit for you.
I have a loop that can go on for ages, although the "Enheder" worksheet only has like 10 rows, and the dataset im loadin has maybe 300 rows, it's taking a REALLY long time when I try to import.
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
Difficult to debug without the source files.
I see the following potential problems:
GetRowRange: .UsedRange might return more columns than you expect. Check by pressing Ctrl-End in the worksheet and see where you end up
Some thing in your main routine - depsheet.UsedRange.Columns(1).Cells might just result in much more rows than expected
someRange.Value = "VLOOKUP(... will store the formula as text. You need .Formula = instead of .Value (this will not solve your long runtime but certainly avoid another bug)
In sortSpgs you add know or unknow items to a control. Not knowing if there's any event code behind these controls, disable events with Application.EnableEvents=False (ideally in the beginning of your main sub together with the .ScreenUpdating = False)
Also, set Application.Calculation = xlCalculationManual at the beginning and Application.Calculation = xlCalculationAutomatic at the end of your code
You're performing a lot of .Find - esp. in sortSpgs - this is potentially slow in large sheets, as it has to loop over quite some data, depending on the underlying range.
Generally, a few more "best practise remarks":
* Dim your variables with the correct types, same for returns of functions
* Use With obj to make the code cleaner. E.g. in setResulcolVars you could use With rsheet.UsedRange and remove this part in the following 15 or so lines
* In modules of small scope, it is okay to dim some variable with a module wide scope - esp. if you hand them over with every call. This will make your code much easier to read
Hope that helps a bit... mvh /P.
My guess is that Application.Screenupdating is the problem. You set to false inside the:
if Not (importsheet.UsedRange.Find("afdeling") Is Nothing) Then
block. So if the isn't the case then screenupdateing isn't disabled. you should move it to the beginning of the function.
you could also try to write the usedrange in an array, work with it , and write it back if needed.
code example
dim MyArr() as Variant
redim MyArray (1 to usedrange.rows.count, 1 to usedrange.columns)
MyArray=usedrange.value
'calculating with Myarray instead of ranges (faster)
usedrange.value=myarray 'writes changes back to the sheet/range
also, maybe you can use .match instead of .find, wich is faster.
with arrays you use application.match( SearchValue, Array_Name, False) 'false if for exact match
the same thing works for range.find() , becoming application.find()...
save first your master workbook under a new name before making such a big change...