Makro making Excel stop working

**gandreso** · 06-28-2016, 04:41 AM

I have a problem. Sometimes when I run my makro, excel stops working and I have to exit excel. What can cause excel to stop working?
The thing is if I use red clicks in visual basics and run the makro using F5, the makro works fine.

Thanks in advance.

**:) Sixthsense :)** · 06-28-2016, 05:11 AM

May be your code goes on continuous looping...

Just share your code so that we can have a look and suggest something to get rid of this issue.

**gandreso** · 06-28-2016, 05:54 AM


Option Explicit
Public SetFolders As New SetFolders
Public SetFilesVar As New SetFilesVar

Public startDoc, projDoc, sheetSettings, sheetMain, sheetVehicles   As String
Public rubrikNamn(100) As Variant
Public stdRubrikNamn(100), radRubriknamn(100)
Public antalRubrik As Integer
Public datumNamn(100), serieNamn(100), kvartal(100), år(100), vehicle(100), KOL(100)
Public antalDatum As Integer
Public failCounter, pivåCounter As Integer

Sub Run()
  
 
  Dim sCol, Summa, sYear, sRow, r, rr, c, cc, i, ii, n, kv, year, veh, ser, actP
  
  Application.DisplayAlerts = False
  
  
  Application.ScreenUpdating = False
  
  
  sheetSettings = "Settings"
  
 
  sheetMain = "Main"
  
  failCounter = 1
  pivåCounter = 1
  
  
  actP = ActiveWorkbook.Path
  
  
  sheetVehicles = "Vehicles"
  
  
  Sheets(sheetVehicles).Visible = True
  
  
  startDoc = ActiveWorkbook.Name
  projDoc = ActiveWorkbook.Name
  
  
  Worksheets("CheckDoc").Activate
  Range("A2:IV1000").ClearContents
  
  
  Worksheets("Pivådata").Activate
  Range("A2:IV5000").ClearContents
  
  
  Worksheets(sheetMain).Activate
  Range("3:1000").ClearContents
  Rows("3:1000").Select
  
  
  Selection.NumberFormat = "General"
  With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
  End With
  Selection.Font.Bold = False
  Selection.ClearOutline
  
  ' --------

  sCol = MatchTextCol("Q1", 1, 100, 2)
  
  
  sYear = Cells(1, sCol).Value - 2000
  
  
  Call SetFilesVar.init(actP & "\Project", ".xls")
  
  
  For n = 1 To SetFilesVar.noOfFiles
    projDoc = SetFilesVar.Files(n)
          
   ' copy data
    Workbooks.Open fileName:=actP & "\Project\" & projDoc
    Sheets("Vehicles").Activate
    Cells.Select
    Selection.Copy
    Workbooks(startDoc).Activate
    Sheets("Vehicles").Select
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
      
    Workbooks(projDoc).Activate
    Workbooks(projDoc).Close
      
   '-----------------------------
     
    If checkRubrik = True Then
        
      If checkDate = True Then
       
      ' Workbooks(startDoc).Activate
       Worksheets(sheetMain).Activate
           
       sRow = LRowFromEnd(1, "", "") + 2
       Cells(sRow, 1).Value = projDoc
       Cells(sRow, 1).Font.Bold = True
     
       For i = 1 To antalRubrik
         r = radRubriknamn(i)
         rr = sRow + i
         Cells(rr, 1).Value = stdRubrikNamn(i)
         For ii = 1 To antalDatum
           c = KOL(ii)
           kv = kvartal(ii)
           year = år(ii)
           veh = vehicle(ii)
           ser = serieNamn(ii)
            ' cc= (sCol-1)+sYear*(år-sYear)+ 3*(kv-1)+veh ' col
           cc = (sCol - 1) + 12 * (year - sYear) + 3 * (kv - 1) + veh ' col
           Cells(sRow, cc).Value = ser
           Cells(sRow, cc).Select
           With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 90
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
           End With
           pivåCounter = pivåCounter + 1
           'År  Kvartal Projektdok  Rubrik  Serie   Antal h
           Cells(rr, cc).Value = Worksheets(sheetVehicles).Cells(r, c).Value
           Worksheets("Pivådata").Cells(pivåCounter, 1).Value = 2000 + Val(year)
           Worksheets("Pivådata").Cells(pivåCounter, 2).Value = kv
           Worksheets("Pivådata").Cells(pivåCounter, 3).Value = projDoc
           Worksheets("Pivådata").Cells(pivåCounter, 4).Value = stdRubrikNamn(i)
           Worksheets("Pivådata").Cells(pivåCounter, 5).Value = ser
           Worksheets("Pivådata").Cells(pivåCounter, 6).Value = Worksheets(sheetVehicles).Cells(r, c).Value
           Cells(sRow + antalRubrik + 1, cc).FormulaR1C1 = "=SUM(R[-" & (antalRubrik) & "]C:R[-1]C)"
           Cells(sRow + antalRubrik + 1, cc).Font.Bold = True
         Next ii
       Next i
       Cells(rr + 1, 1).Value = "Summa:"
       Cells(rr + 1, 1).HorizontalAlignment = xlRight
       Cells(rr + 1, 1).Font.Bold = True
       Rows(sRow + 1 & ":" & rr).Select
       Selection.Rows.Group
      End If
     End If
  Next n
  
  Worksheets("Pivådata").Activate

 
  Dim eRow
  eRow = lrow(1, 1, "", "")

  Columns("A:M").Select
  
  Worksheets("Pivådata").Sort.SortFields.Clear
  
  Worksheets("Pivådata").Sort.SortFields.Add Key:=Range( _
    "A2:A" & eRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
     xlSortNormal
  
  Worksheets("Pivådata").Sort.SortFields.Add Key:=Range( _
     "B2:B" & eRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
    xlSortNormal
  With Worksheets("Pivådata").Sort
        .SetRange Range("A1:M" & eRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
  End With
  For i = 1 To 20
    If SheetExist("Tabell" & i) = True Then Worksheets("Tabell" & i).PivotTables("PivotTable1").PivotCache.Refresh
  Next i
  '----------------
  
  Worksheets(sheetMain).Activate
  If failCounter > 1 Then Worksheets("CheckDoc").Activate
  Sheets(sheetVehicles).Visible = False
  'Uppdaterar skärmen igen automatiskt
  Application.ScreenUpdating = True
  
  
  Application.DisplayAlerts = True
End Sub


Function kvartalCalc(week)
    
    Dim vv, wdate
    
    
    vv = Val(Right(week, 2))
    
    
    If vv > 39 Then
      kvartalCalc = 4
      Exit Function
      
    
    End If
    If vv > 26 Then
      kvartalCalc = 3
      Exit Function
      
    
    End If
    If vv > 13 Then
      kvartalCalc = 2
      Exit Function
      
    
    End If
    kvartalCalc = 1
 End Function
    
Function checkRubrik()
  
  Dim i, ii, no, r, eRow As Long
  Dim rubrik(5) As Variant
  checkRubrik = True
 ' Workbooks(startDoc).Activate
  Worksheets(sheetSettings).Activate
  eRow = lrow(1, 1, "", "")
 ' Workbooks(projDoc).Activate
  Worksheets(sheetVehicles).Activate
  For i = 1 To 150
   Cells(i, 1).Value = Trim(Cells(i, 1).Value)
  Next i
  
  For i = 2 To eRow
    For ii = 1 To 5
      no = ii
      stdRubrikNamn(i - 1) = Worksheets(sheetSettings).Cells(i, 1).Value
      rubrik(no) = Worksheets(sheetSettings).Cells(i, no).Value
      r = MatchTextRow(rubrik(no), 1, 1000, 1, 0)
      If r > 0 Then Exit For
    Next ii
    If r = 0 Then
      Dim FText
      FText = "Rubriken " & Worksheets(sheetSettings).Cells(i, 1).Value & " finns inte i projektdokumentet"
      checkRubrik = False
      failCounter = failCounter + 1
      Worksheets("CheckDoc").Cells(failCounter, 1).Value = projDoc
      Worksheets("CheckDoc").Cells(failCounter, 2).Value = FText
      'Exit Function
     Else
      If Cells(r, 1).Value <> rubrik(no) Then
        FText = "Rubriken " & Worksheets(sheetSettings).Cells(i, no).Value & " har små bokstäver i projektdokumentet"
        checkRubrik = False
        failCounter = failCounter + 1
        Worksheets("CheckDoc").Cells(failCounter, 1).Value = projDoc
        Worksheets("CheckDoc").Cells(failCounter, 2).Value = FText
       'Exit Function
      End If
      If checkRubrik = True Then
         radRubriknamn(i - 1) = r
         rubrikNamn(i - 1) = rubrik(no)
      End If
    End If
  Next i
  antalRubrik = eRow - 1
End Function
Function checkDate()

  
  
  Dim i, ii, j, no, r, eCol As Long
  
  
  Dim rubrik(5) As Variant
  
  
  Dim dat As Date
  
  
  Dim text, wdate
  Dim år_1, kv_1
  checkDate = False

 ' Workbooks(projDoc).Activate
  Worksheets(sheetVehicles).Activate
  

  eCol = 150
  For i = 1 To eCol
     Cells(5, i).Value = Trim(Cells(5, i).Value)

  Next i

  For i = 1 To eCol
    wdate = Cells(5, i).Value
    
    text = GetDate(wdate)
    If text <> 0 Then
      ii = ii + 1
      KOL(ii) = i
      år(ii) = Left(wdate, 2)  '
      kvartal(ii) = kvartalCalc(wdate)
      antalDatum = ii
      serieNamn(ii) = Cells(1, i).Value
      datumNamn(ii) = text
      j = 1
      If år(ii) = år_1 And kv_1 = kvartal(ii) Then
        j = j + 1
      End If
      vehicle(ii) = j
      år_1 = år(ii)
      kv_1 = kvartal(ii)
      checkDate = True
    End If
  Next i
        
End Function

' *********************************


Option Explicit

' Används för getFileName
Private Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long
'------

Function GetFileName(expath, Title, prefix, Optional multiselectVal)
  
  Dim vFileToOpen As Variant
  Dim strCurDir As String
  '// Keep Original Dir
  strCurDir = CurDir
  
  '// Note: If the UNC path does not exist then
  '// It will default to your current one
  SetCurrentDirectory expath
  If IsMissing(multiselectVal) = True Then
    GetFileName = Application.GetOpenFilename(Title & " (*" & prefix & "), *" & prefix & "")
   Else
    GetFileName = Application.GetOpenFilename(Title & " (*" & prefix & "), *" & prefix & "", 0, "", "", multiselectVal)
  End If
 
  expath = CurDir
  If TypeName(GetFileName) = "Boolean" Then Exit Function
   '// The rest of your code
    
   '// End by resetting to last/original Dir
  ChDir strCurDir
End Function
Sub saveActiveFile(fileName)
 ' save Activefile
' #If VBA7 Then
'   ActiveWorkbook.SaveAs filename:=filename, FileFormat:=xlExcel8
' #Else
   ActiveWorkbook.SaveAs fileName:=fileName
' #End If
End Sub

Sub CreateExcelInstance(wbFileName)
    'Open the workbook in the new instance of Excel and set visible
    'If the workbook doesn't exist (a new workbook) then
    'create a new one in the new Excel instance
    'Procuce a plot if typeOfConv = "Plot"
    Dim xl As New Excel.Application
    On Error Resume Next
    xl.Workbooks.Open wbFileName
    xl.Visible = True
    If xl.Worksheets.Count = 3 Then xl.Worksheets(1).Activate
    Set xl = Nothing
End Sub

' **** Övriga ofta använda

Function MatchTextRow(Rangetext, Startline, Stopline, col, Optional TypeOfS)
 ' Find row fast for RangeText
 Dim TypeOfSearch
 Dim i As Long
 On Error GoTo Errorhandler
 i = 0
 If IsMissing(TypeOfS) = True Then
   TypeOfSearch = 0 ' Exact match
  Else
   TypeOfSearch = TypeOfS ' -1 op 1  se help for Match funcion in Excel
 End If
 If Rangetext = "" Then
   For i = Startline To Stopline
     If UCase(Rangetext) = UCase(Cells(i, col)) Then
       MatchTextRow = i - (Startline - 1)
       Exit Function
     End If
   Next i
 End If
 MatchTextRow = Application.WorksheetFunction.Match(Rangetext, Range(Cells(Startline, col), Cells(Stopline, col)), TypeOfSearch)
 MatchTextRow = MatchTextRow + (Startline - 1)
 Exit Function
Errorhandler:
 MatchTextRow = 0
End Function
Function MatchTextCol(Rangetext, StartCol, StopCol, row)
 ' Finn kolumn för RangeText
 Dim actS As String
 Dim i As Long
 On Error GoTo Errorhandler
 If Rangetext = "" Then
    For i = StartCol To StopCol
      If UCase(Rangetext) = UCase(Cells(row, i)) Then
        MatchTextCol = i + (StartCol - 1)
        Exit Function
      End If
    Next i
 End If
 MatchTextCol = Application.WorksheetFunction.Match(Rangetext, _
 Range(Cells(row, StartCol), Cells(row, StopCol)), 0)
 MatchTextCol = MatchTextCol + (StartCol - 1)
 Exit Function
Errorhandler:  MatchTextCol = 0
End Function
Function GetFilesVar(Folder, noOfFiles, prefix)
  
   Dim fc As Variant
   Dim f
   Dim i As Long
   Dim Fil() As Variant
   Dim fs As New Scripting.FileSystemObject
   Set fc = fs.GetFolder(Folder).Files
   noOfFiles = 0
   For Each f In fc
     If Right(f.Name, Len(prefix)) = prefix Then
       i = i + 1
       ReDim Preserve Fil(i)
       Fil(i) = f.Name
       noOfFiles = noOfFiles + 1
     End If
   Next
   GetFilesVar = Fil
End Function

Function GetFiles(Folder, noOfFiles)
  
   Dim fc As Variant
   Dim f
   Dim i As Long
   Dim Fil() As Variant
   Dim cond As Boolean
   Dim fs As New Scripting.FileSystemObject
   Set fc = fs.GetFolder(Folder).Files
   For Each f In fc
     If frmPlot.ChBox_Viewscg = True Then cond = Right(f.Name, 5) = ".xlsm" Or Right(f.Name, 4) = ".scg" Or Right(f.Name, 5) = ".xlsx"
     If frmPlot.ChBox_Viewscg = False Then cond = Right(f.Name, 5) = ".xlsm" Or Right(f.Name, 5) = ".xlsx"
     If cond = True Then
       i = i + 1
       ReDim Preserve Fil(i)
       Fil(i) = f.Name
       noOfFiles = noOfFiles + 1
     End If
   Next
   GetFiles = Fil
End Function
Function GetFilesVB(Folder, noOfFiles)
   
   Dim fc As Variant
   Dim f
   Dim i As Long
   Dim Fil() As Variant
   Dim fs As New Scripting.FileSystemObject
   Set fc = fs.GetFolder(Folder).Files
   For Each f In fc
     If Right(f.Name, 4) = ".bas" = True Then
       i = i + 1
       ReDim Preserve Fil(i)
       Fil(i) = f.Name
       noOfFiles = noOfFiles + 1
     End If
   Next
   GetFilesVB = Fil
End Function
Function GetFolder(Folder, noofFolder)
  
   Dim fc As Variant
   Dim f
   Dim i As Long
   Dim Fold() As Variant
   Dim fs As New Scripting.FileSystemObject
   Set fc = fs.GetFolder(Folder).SubFolders
   For Each f In fc
       i = i + 1
       ReDim Preserve Fold(i)
       Fold(i) = f.Name
       noofFolder = noofFolder + 1
   Next
   GetFolder = Fold
End Function
Function lrow(row, col, ActB, actS)
  ' Last row. O if first are Blank
  Dim actB1, ActS1 As String
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  lrow = Cells(row, col).End(xlDown).row
  If lrow = Cells.Rows.Count Then
    If Cells(Cells.Rows.Count, col).Value = "" Then
      If Cells(row, col).Value <> "" Then lrow = row
      If Cells(row, col).Value = "" Then lrow = row - 1
    End If
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function

**gandreso** · 06-28-2016, 05:55 AM


Function LRowFromEnd(col, ActB, actS)
  ' Lastrow from end
  Dim actB1, ActS1
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LRowFromEnd = Cells(Cells.Rows.Count, col).End(xlUp).row
  If LRowFromEnd = 1 Then
   If Cells(1, col).Value = "" Then LRowFromEnd = 0
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function LCol(row, col, ActB, actS)
  ' Last Col , O if first are blank
  Dim actB1, ActS1 As String
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LCol = Cells(row, col).End(xlToRight).Column
  If LCol = Cells.Columns.Count Then
    If Cells(row, Cells.Columns.Count).Value = "" Then
      If Cells(row, col) <> "" Then LCol = col
      If Cells(row, col) = "" Then LCol = col - 1
    End If
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function TestFileOpen(file)
 ' Test if file is open
 Dim w
 TestFileOpen = False
 For Each w In Workbooks
   ' If File is open
   If w.Name = file Then
      TestFileOpen = True
      Exit Function
   End If
 Next w
End Function
Function closeAllExceptOne(testname)
  ' close all except one
  Dim w
  Application.DisplayAlerts = False
  closeAllExceptOne = False
  For Each w In Workbooks
   ' close if <> testname
   If w.Name <> testname Then
      Workbooks(w.Name).Close
   End If
  Next w
  closeAllExceptOne = True
  ''Application.DisplayAlerts = True
End Function
Function SheetExist(sheet)
 
 Dim w
 SheetExist = False
 For Each w In ActiveWorkbook.Sheets
   If w.Name = sheet Then SheetExist = True
 Next w
End Function
Sub DeleteSheet(sheetName)
    ' Delete sheet before save
    Dim i
    ' Delete Sheet
    If SheetExist(sheetName) = True Then Sheets(sheetName).Delete
End Sub


Sub Rename(sheet, From)
  ' Rename Sheet
  On Error GoTo errorHandling
  Sheets(sheet).Name = n
End Sub
Sub CreateNewSheet(sheet, From, Place)
' Copy new sheet from Sheet
  On Error GoTo Errorhandler
    If Place = "before" Then
      Sheets(From).Copy before:=Sheets(From)
     Else
      Sheets(From).Copy After:=Sheets(From)
    End If
     Sheets("" & From & " (2)").Select
     Sheets("" & From & " (2)").Name = sheet
  Exit Sub
Errorhandler:
Application.ScreenUpdating = True
MsgBox "Problably something wrong with Diagramname. Change The Diagramname!!"
Application.Visible = True
End Sub

Sub InputBoxSub()
    Dim message, Title, default, MyValue
    message = "Enter a value between 1 and 3"    ' Set prompt.
    Title = "InputBox Demo"    ' Set title.
    default = "1"    ' Set default.
    ' Display message, title, and default value.
    MyValue = InputBox(message, Title, default)
    
    ' Use Helpfile and context. The Help button is added automatically.
    MyValue = InputBox(message, Title, , , , "DEMO.HLP", 10)
    
    ' Display dialog box at position 100, 100.
    MyValue = InputBox(message, Title, default, 100, 100)

End Sub
Sub msgboxSub()
    Dim Msg, Style, Title, Help, Ctxt, Response, mystring
    Msg = "Do you want to continue ?"    ' Define message.
    Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
    Title = "MsgBox Demonstration"    ' Define title.
    Help = "DEMO.HLP"    ' Define Help file.
    Ctxt = 1000    ' Define topic
            ' context.
            ' Display message.
    Response = MsgBox(Msg, Style, Title, Help, Ctxt)
    If Response = vbYes Then    ' User chose Yes.
        mystring = "Yes"    ' Perform some action.
    Else    ' User chose No.
        mystring = "No"    ' Perform some action.
    End If
End Sub

Sub wait(sec)
  Dim newhour, newminute, newsecond, waittime
  newhour = Hour(Now())
  newminute = Minute(Now())
  newsecond = Second(Now()) + sec
  waittime = TimeSerial(newhour, newminute, newsecond)
  Application.wait waittime
End Sub

Sub helpdoc()
  ' open helpdoc
   Dim aa
   aa = Shell("Winword " & """" & Folder.MainPath & "\help.doc" & """", 1)
End Sub

Function GetFolderName(strPath As String, Title As String) As String
    ' Open folderdialog
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = Title
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolderName = sItem
    Set fldr = Nothing
End Function

Sub createDokWithNoSheets(no, fname)
  ' create workbook with sheetname 1,2,3 ...x
  Dim i As Integer
  Application.DisplayAlerts = False
  Workbooks.Add
  For i = 1 To no
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = i & ""
  Next i
  For i = 1 To Sheets.Count
    If SheetExist("Sheet" & i) = True Then Call DeleteSheet("Sheet" & i)
  Next i
  Worksheets(1).Activate
  If fname <> "" Then ActiveWorkbook.SaveAs fname
End Sub
Function noOfSheetInNotOpenWorkbook(fileName, sheetnames)
    ' check noof sheets
    On Error GoTo errorHandling
    noOfSheetInNotOpenWorkbook = 0
    Dim i As Long
    Dim Shell As Object: Set Shell = CreateObject("WScript.Shell")
    Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
    Dim objExcel As Application: Set objExcel = CreateObject("Excel.Application")
    Dim myworkbook As Workbook, worksheetcount As Long
    Set myworkbook = objExcel.Workbooks.Open(fileName)
    On Error Resume Next
    worksheetcount = myworkbook.Worksheets.Count
    noOfSheetInNotOpenWorkbook = worksheetcount
    For i = 1 To worksheetcount
      sheetnames(i) = myworkbook.Worksheets(i).Name
    Next i
    myworkbook.Close
    If Err.Number <> 0 Then
       ' ShowError
        myworkbook.Close False
    End If
errorHandling:
End Function

Option Explicit



Function GetDate(wdate)
    ' Hämtar datum från format ååWvvd
    ' Get date from format
    ' Wdate= 05W18 (Year 05 Week 18 )
    ' Kjell Arby
    Dim i As Long
    Dim sp
    Dim Y As Integer
    Dim M As Integer
    Dim D As Integer
    Dim Data(4)
    On Error GoTo errorHandling
    GetDate = 0 ' If not correct input
    If Len(wdate) <> 5 Then Exit Function
    sp = Split(wdate, "W")
    If UBound(sp) = 0 Then sp = Split(wdate, "w")
    For i = 0 To UBound(sp)
      Data(i) = sp(i)
    Next i
    If Len(Data(1)) < 2 Then Exit Function
    Y = Data(0)
    M = Left(Data(1), 2)
    GetDate = YearStart(Y) + (M - 1) * 7
    Exit Function
errorHandling:
    GetDate = 0 ' If not correct input
End Function

Function YearStart(WhichYear As Integer) As Date
    ' Funktion från Internet
    ' Start Year
    Dim WeekDay As Integer
    Dim NewYear As Date
    'On Error GoTo errorhandling
    NewYear = DateSerial(WhichYear, 1, 1)
    WeekDay = (NewYear - 2) Mod 7
    If WeekDay < 4 Then
        YearStart = NewYear - WeekDay
    Else
        YearStart = NewYear - WeekDay + 7
    End If
    Exit Function
errorHandling:
End Function
Function ISOWeekNum(AnyDate As Date, _
     Optional WhichFormat As Variant) As Integer
    ' Function from Internet
    ' WhichFormat: missing or <> 2 then returns week number,
    '              = 2 then YYWW
    '
    Dim ThisYear As Integer
    Dim PreviousYearStart As Date
    Dim ThisYearStart As Date
    Dim NextYearStart As Date
    Dim YearNum As Integer
 '   On Error GoTo errorhandling
    ThisYear = year(AnyDate)
    
    ThisYearStart = YearStart(ThisYear)
    
    PreviousYearStart = YearStart(ThisYear - 1)
    NextYearStart = YearStart(ThisYear + 1)
    Select Case AnyDate
        Case Is >= NextYearStart
            ISOWeekNum = (AnyDate - NextYearStart) \ 7 + 1
            YearNum = year(AnyDate) + 1
        Case Is < ThisYearStart
            ISOWeekNum = (AnyDate - PreviousYearStart) \ 7 + 1
            YearNum = year(AnyDate) - 1
        Case Else
            ISOWeekNum = (AnyDate - ThisYearStart) \ 7 + 1
            YearNum = year(AnyDate)
    End Select
    If IsMissing(WhichFormat) Then
        Exit Function
    End If
    If WhichFormat = 2 Then
        ISOWeekNum = CInt(Format(Right(YearNum, 2), "00") & _
        Format(ISOWeekNum, "00"))
    End If
    Exit Function
'errorhandling:  Call SaveLogfile("Function ISOWeekNum", Err.Description)
End Function

Class modules:


Option Explicit
' Anrop: SetFiles.init(folder,prefix)
' Returnerar
'   SetFiles.Files(i)   namn
'   SetFiles.noofFiles  antal

Private v_Files() As Variant
Private i_noofFiles As Long

Sub init(lib, prefix)
  Dim fs As New Scripting.FileSystemObject
  i_noofFiles = 0
  If fs.FolderExists(lib) = False Then Exit Sub
  v_Files = GetFilesVar(lib, i_noofFiles, prefix)
End Sub

Public Property Get Files() As Variant
  Files = v_Files
End Property
Public Property Get noOfFiles() As Long
  noOfFiles = i_noofFiles
End Property

Option Explicit
' Anrop: SetFolders.init(folder)
' Returnerar
'   SetFolders.Folder(i)   namn
'   SetFolders.noofFolder  antal

Private v_Folder() As Variant
Private i_noofFolder As Long
Sub init(lib)
  i_noofFolder = 0
  v_Folder = GetFolder(lib, i_noofFolder)
End Sub

Public Property Get Folder() As Variant
  Folder = v_Folder
End Property
Public Property Get noofFolder() As Long
  noofFolder = i_noofFolder
End Property

**gandreso** · 06-28-2016, 05:55 AM

The code continue:

Function LRowFromEnd(col, ActB, actS)
  ' Lastrow from end
  Dim actB1, ActS1
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LRowFromEnd = Cells(Cells.Rows.Count, col).End(xlUp).row
  If LRowFromEnd = 1 Then
   If Cells(1, col).Value = "" Then LRowFromEnd = 0
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function LCol(row, col, ActB, actS)
  ' Last Col , O if first are blank
  Dim actB1, ActS1 As String
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LCol = Cells(row, col).End(xlToRight).Column
  If LCol = Cells.Columns.Count Then
    If Cells(row, Cells.Columns.Count).Value = "" Then
      If Cells(row, col) <> "" Then LCol = col
      If Cells(row, col) = "" Then LCol = col - 1
    End If
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function TestFileOpen(file)
 ' Test if file is open
 Dim w
 TestFileOpen = False
 For Each w In Workbooks
   ' If File is open
   If w.Name = file Then
      TestFileOpen = True
      Exit Function
   End If
 Next w
End Function
Function closeAllExceptOne(testname)
  ' close all except one
  Dim w
  Application.DisplayAlerts = False
  closeAllExceptOne = False
  For Each w In Workbooks
   ' close if <> testname
   If w.Name <> testname Then
      Workbooks(w.Name).Close
   End If
  Next w
  closeAllExceptOne = True
  ''Application.DisplayAlerts = True
End Function
Function SheetExist(sheet)
 
 Dim w
 SheetExist = False
 For Each w In ActiveWorkbook.Sheets
   If w.Name = sheet Then SheetExist = True
 Next w
End Function
Sub DeleteSheet(sheetName)
    ' Delete sheet before save
    Dim i
    ' Delete Sheet
    If SheetExist(sheetName) = True Then Sheets(sheetName).Delete
End Sub


Sub Rename(sheet, From)
  ' Rename Sheet
  On Error GoTo errorHandling
  Sheets(sheet).Name = n
End Sub
Sub CreateNewSheet(sheet, From, Place)
' Copy new sheet from Sheet
  On Error GoTo Errorhandler
    If Place = "before" Then
      Sheets(From).Copy before:=Sheets(From)
     Else
      Sheets(From).Copy After:=Sheets(From)
    End If
     Sheets("" & From & " (2)").Select
     Sheets("" & From & " (2)").Name = sheet
  Exit Sub
Errorhandler:
Application.ScreenUpdating = True
MsgBox "Problably something wrong with Diagramname. Change The Diagramname!!"
Application.Visible = True
End Sub

Sub InputBoxSub()
    Dim message, Title, default, MyValue
    message = "Enter a value between 1 and 3"    ' Set prompt.
    Title = "InputBox Demo"    ' Set title.
    default = "1"    ' Set default.
    ' Display message, title, and default value.
    MyValue = InputBox(message, Title, default)
    
    ' Use Helpfile and context. The Help button is added automatically.
    MyValue = InputBox(message, Title, , , , "DEMO.HLP", 10)
    
    ' Display dialog box at position 100, 100.
    MyValue = InputBox(message, Title, default, 100, 100)

End Sub
Sub msgboxSub()
    Dim Msg, Style, Title, Help, Ctxt, Response, mystring
    Msg = "Do you want to continue ?"    ' Define message.
    Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
    Title = "MsgBox Demonstration"    ' Define title.
    Help = "DEMO.HLP"    ' Define Help file.
    Ctxt = 1000    ' Define topic
            ' context.
            ' Display message.
    Response = MsgBox(Msg, Style, Title, Help, Ctxt)
    If Response = vbYes Then    ' User chose Yes.
        mystring = "Yes"    ' Perform some action.
    Else    ' User chose No.
        mystring = "No"    ' Perform some action.
    End If
End Sub

Sub wait(sec)
  Dim newhour, newminute, newsecond, waittime
  newhour = Hour(Now())
  newminute = Minute(Now())
  newsecond = Second(Now()) + sec
  waittime = TimeSerial(newhour, newminute, newsecond)
  Application.wait waittime
End Sub

Sub helpdoc()
  ' open helpdoc
   Dim aa
   aa = Shell("Winword " & """" & Folder.MainPath & "\help.doc" & """", 1)
End Sub

Function GetFolderName(strPath As String, Title As String) As String
    ' Open folderdialog
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = Title
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolderName = sItem
    Set fldr = Nothing
End Function

Sub createDokWithNoSheets(no, fname)
  ' create workbook with sheetname 1,2,3 ...x
  Dim i As Integer
  Application.DisplayAlerts = False
  Workbooks.Add
  For i = 1 To no
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = i & ""
  Next i
  For i = 1 To Sheets.Count
    If SheetExist("Sheet" & i) = True Then Call DeleteSheet("Sheet" & i)
  Next i
  Worksheets(1).Activate
  If fname <> "" Then ActiveWorkbook.SaveAs fname
End Sub
Function noOfSheetInNotOpenWorkbook(fileName, sheetnames)
    ' check noof sheets
    On Error GoTo errorHandling
    noOfSheetInNotOpenWorkbook = 0
    Dim i As Long
    Dim Shell As Object: Set Shell = CreateObject("WScript.Shell")
    Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
    Dim objExcel As Application: Set objExcel = CreateObject("Excel.Application")
    Dim myworkbook As Workbook, worksheetcount As Long
    Set myworkbook = objExcel.Workbooks.Open(fileName)
    On Error Resume Next
    worksheetcount = myworkbook.Worksheets.Count
    noOfSheetInNotOpenWorkbook = worksheetcount
    For i = 1 To worksheetcount
      sheetnames(i) = myworkbook.Worksheets(i).Name
    Next i
    myworkbook.Close
    If Err.Number <> 0 Then
       ' ShowError
        myworkbook.Close False
    End If
errorHandling:
End Function

Option Explicit



Function GetDate(wdate)
    ' Hämtar datum från format ååWvvd
    ' Get date from format
    ' Wdate= 05W18 (Year 05 Week 18 )
    ' Kjell Arby
    Dim i As Long
    Dim sp
    Dim Y As Integer
    Dim M As Integer
    Dim D As Integer
    Dim Data(4)
    On Error GoTo errorHandling
    GetDate = 0 ' If not correct input
    If Len(wdate) <> 5 Then Exit Function
    sp = Split(wdate, "W")
    If UBound(sp) = 0 Then sp = Split(wdate, "w")
    For i = 0 To UBound(sp)
      Data(i) = sp(i)
    Next i
    If Len(Data(1)) < 2 Then Exit Function
    Y = Data(0)
    M = Left(Data(1), 2)
    GetDate = YearStart(Y) + (M - 1) * 7
    Exit Function
errorHandling:
    GetDate = 0 ' If not correct input
End Function

Function YearStart(WhichYear As Integer) As Date
    ' Funktion från Internet
    ' Start Year
    Dim WeekDay As Integer
    Dim NewYear As Date
    'On Error GoTo errorhandling
    NewYear = DateSerial(WhichYear, 1, 1)
    WeekDay = (NewYear - 2) Mod 7
    If WeekDay < 4 Then
        YearStart = NewYear - WeekDay
    Else
        YearStart = NewYear - WeekDay + 7
    End If
    Exit Function
errorHandling:
End Function
Function ISOWeekNum(AnyDate As Date, _
     Optional WhichFormat As Variant) As Integer
    ' Function from Internet
    ' WhichFormat: missing or <> 2 then returns week number,
    '              = 2 then YYWW
    '
    Dim ThisYear As Integer
    Dim PreviousYearStart As Date
    Dim ThisYearStart As Date
    Dim NextYearStart As Date
    Dim YearNum As Integer
 '   On Error GoTo errorhandling
    ThisYear = year(AnyDate)
    
    ThisYearStart = YearStart(ThisYear)
    
    PreviousYearStart = YearStart(ThisYear - 1)
    NextYearStart = YearStart(ThisYear + 1)
    Select Case AnyDate
        Case Is >= NextYearStart
            ISOWeekNum = (AnyDate - NextYearStart) \ 7 + 1
            YearNum = year(AnyDate) + 1
        Case Is < ThisYearStart
            ISOWeekNum = (AnyDate - PreviousYearStart) \ 7 + 1
            YearNum = year(AnyDate) - 1
        Case Else
            ISOWeekNum = (AnyDate - ThisYearStart) \ 7 + 1
            YearNum = year(AnyDate)
    End Select
    If IsMissing(WhichFormat) Then
        Exit Function
    End If
    If WhichFormat = 2 Then
        ISOWeekNum = CInt(Format(Right(YearNum, 2), "00") & _
        Format(ISOWeekNum, "00"))
    End If
    Exit Function
'errorhandling:  Call SaveLogfile("Function ISOWeekNum", Err.Description)
End Function

Class modules:


Option Explicit
' Anrop: SetFiles.init(folder,prefix)
' Returnerar
'   SetFiles.Files(i)   namn
'   SetFiles.noofFiles  antal

Private v_Files() As Variant
Private i_noofFiles As Long

Sub init(lib, prefix)
  Dim fs As New Scripting.FileSystemObject
  i_noofFiles = 0
  If fs.FolderExists(lib) = False Then Exit Sub
  v_Files = GetFilesVar(lib, i_noofFiles, prefix)
End Sub

Public Property Get Files() As Variant
  Files = v_Files
End Property
Public Property Get noOfFiles() As Long
  noOfFiles = i_noofFiles
End Property

Option Explicit
' Anrop: SetFolders.init(folder)
' Returnerar
'   SetFolders.Folder(i)   namn
'   SetFolders.noofFolder  antal

Private v_Folder() As Variant
Private i_noofFolder As Long
Sub init(lib)
  i_noofFolder = 0
  v_Folder = GetFolder(lib, i_noofFolder)
End Sub

Public Property Get Folder() As Variant
  Folder = v_Folder
End Property
Public Property Get noofFolder() As Long
  noofFolder = i_noofFolder
End Property

**gandreso** · 06-28-2016, 05:59 AM

Function LRowFromEnd(col, ActB, actS)
  ' Lastrow from end
  Dim actB1, ActS1
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LRowFromEnd = Cells(Cells.Rows.Count, col).End(xlUp).row
  If LRowFromEnd = 1 Then
   If Cells(1, col).Value = "" Then LRowFromEnd = 0
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function LCol(row, col, ActB, actS)
  ' Last Col , O if first are blank
  Dim actB1, ActS1 As String
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LCol = Cells(row, col).End(xlToRight).Column
  If LCol = Cells.Columns.Count Then
    If Cells(row, Cells.Columns.Count).Value = "" Then
      If Cells(row, col) <> "" Then LCol = col
      If Cells(row, col) = "" Then LCol = col - 1
    End If
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function TestFileOpen(file)
 ' Test if file is open
 Dim w
 TestFileOpen = False
 For Each w In Workbooks
   ' If File is open
   If w.Name = file Then
      TestFileOpen = True
      Exit Function
   End If
 Next w
End Function
Function closeAllExceptOne(testname)
  ' close all except one
  Dim w
  Application.DisplayAlerts = False
  closeAllExceptOne = False
  For Each w In Workbooks
   ' close if <> testname
   If w.Name <> testname Then
      Workbooks(w.Name).Close
   End If
  Next w
  closeAllExceptOne = True
  ''Application.DisplayAlerts = True
End Function
Function SheetExist(sheet)
 
 Dim w
 SheetExist = False
 For Each w In ActiveWorkbook.Sheets
   If w.Name = sheet Then SheetExist = True
 Next w
End Function
Sub DeleteSheet(sheetName)
    ' Delete sheet before save
    Dim i
    ' Delete Sheet
    If SheetExist(sheetName) = True Then Sheets(sheetName).Delete
End Sub


Sub Rename(sheet, From)
  ' Rename Sheet
  On Error GoTo errorHandling
  Sheets(sheet).Name = n
End Sub
Sub CreateNewSheet(sheet, From, Place)
' Copy new sheet from Sheet
  On Error GoTo Errorhandler
    If Place = "before" Then
      Sheets(From).Copy before:=Sheets(From)
     Else
      Sheets(From).Copy After:=Sheets(From)
    End If
     Sheets("" & From & " (2)").Select
     Sheets("" & From & " (2)").Name = sheet
  Exit Sub
Errorhandler:
Application.ScreenUpdating = True
MsgBox "Problably something wrong with Diagramname. Change The Diagramname!!"
Application.Visible = True
End Sub

Sub InputBoxSub()
    Dim message, Title, default, MyValue
    message = "Enter a value between 1 and 3"    ' Set prompt.
    Title = "InputBox Demo"    ' Set title.
    default = "1"    ' Set default.
    ' Display message, title, and default value.
    MyValue = InputBox(message, Title, default)
    
    ' Use Helpfile and context. The Help button is added automatically.
    MyValue = InputBox(message, Title, , , , "DEMO.HLP", 10)
    
    ' Display dialog box at position 100, 100.
    MyValue = InputBox(message, Title, default, 100, 100)

End Sub
Sub msgboxSub()
    Dim Msg, Style, Title, Help, Ctxt, Response, mystring
    Msg = "Do you want to continue ?"    ' Define message.
    Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
    Title = "MsgBox Demonstration"    ' Define title.
    Help = "DEMO.HLP"    ' Define Help file.
    Ctxt = 1000    ' Define topic
            ' context.
            ' Display message.
    Response = MsgBox(Msg, Style, Title, Help, Ctxt)
    If Response = vbYes Then    ' User chose Yes.
        mystring = "Yes"    ' Perform some action.
    Else    ' User chose No.
        mystring = "No"    ' Perform some action.
    End If
End Sub

Sub wait(sec)
  Dim newhour, newminute, newsecond, waittime
  newhour = Hour(Now())
  newminute = Minute(Now())
  newsecond = Second(Now()) + sec
  waittime = TimeSerial(newhour, newminute, newsecond)
  Application.wait waittime
End Sub

Sub helpdoc()
  ' open helpdoc
   Dim aa
   aa = Shell("Winword " & """" & Folder.MainPath & "\help.doc" & """", 1)
End Sub

Function GetFolderName(strPath As String, Title As String) As String
    ' Open folderdialog
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = Title
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolderName = sItem
    Set fldr = Nothing
End Function

Sub createDokWithNoSheets(no, fname)
  ' create workbook with sheetname 1,2,3 ...x
  Dim i As Integer
  Application.DisplayAlerts = False
  Workbooks.Add
  For i = 1 To no
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = i & ""
  Next i
  For i = 1 To Sheets.Count
    If SheetExist("Sheet" & i) = True Then Call DeleteSheet("Sheet" & i)
  Next i
  Worksheets(1).Activate
  If fname <> "" Then ActiveWorkbook.SaveAs fname
End Sub
Function noOfSheetInNotOpenWorkbook(fileName, sheetnames)
    ' check noof sheets
    On Error GoTo errorHandling
    noOfSheetInNotOpenWorkbook = 0
    Dim i As Long
    Dim Shell As Object: Set Shell = CreateObject("WScript.Shell")
    Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
    Dim objExcel As Application: Set objExcel = CreateObject("Excel.Application")
    Dim myworkbook As Workbook, worksheetcount As Long
    Set myworkbook = objExcel.Workbooks.Open(fileName)
    On Error Resume Next
    worksheetcount = myworkbook.Worksheets.Count
    noOfSheetInNotOpenWorkbook = worksheetcount
    For i = 1 To worksheetcount
      sheetnames(i) = myworkbook.Worksheets(i).Name
    Next i
    myworkbook.Close
    If Err.Number <> 0 Then
       ' ShowError
        myworkbook.Close False
    End If
errorHandling:
End Function

Option Explicit



Function GetDate(wdate)
    ' Hämtar datum från format ååWvvd
    ' Get date from format
    ' Wdate= 05W18 (Year 05 Week 18 )
    ' Kjell Arby
    Dim i As Long
    Dim sp
    Dim Y As Integer
    Dim M As Integer
    Dim D As Integer
    Dim Data(4)
    On Error GoTo errorHandling
    GetDate = 0 ' If not correct input
    If Len(wdate) <> 5 Then Exit Function
    sp = Split(wdate, "W")
    If UBound(sp) = 0 Then sp = Split(wdate, "w")
    For i = 0 To UBound(sp)
      Data(i) = sp(i)
    Next i
    If Len(Data(1)) < 2 Then Exit Function
    Y = Data(0)
    M = Left(Data(1), 2)
    GetDate = YearStart(Y) + (M - 1) * 7
    Exit Function
errorHandling:
    GetDate = 0 ' If not correct input
End Function

Function YearStart(WhichYear As Integer) As Date
    ' Funktion från Internet
    ' Start Year
    Dim WeekDay As Integer
    Dim NewYear As Date
    'On Error GoTo errorhandling
    NewYear = DateSerial(WhichYear, 1, 1)
    WeekDay = (NewYear - 2) Mod 7
    If WeekDay < 4 Then
        YearStart = NewYear - WeekDay
    Else
        YearStart = NewYear - WeekDay + 7
    End If
    Exit Function
errorHandling:
End Function
Function ISOWeekNum(AnyDate As Date, _
     Optional WhichFormat As Variant) As Integer
    ' Function from Internet
    ' WhichFormat: missing or <> 2 then returns week number,
    '              = 2 then YYWW
    '
    Dim ThisYear As Integer
    Dim PreviousYearStart As Date
    Dim ThisYearStart As Date
    Dim NextYearStart As Date
    Dim YearNum As Integer
 '   On Error GoTo errorhandling
    ThisYear = year(AnyDate)
    
    ThisYearStart = YearStart(ThisYear)
    
    PreviousYearStart = YearStart(ThisYear - 1)
    NextYearStart = YearStart(ThisYear + 1)
    Select Case AnyDate
        Case Is >= NextYearStart
            ISOWeekNum = (AnyDate - NextYearStart) \ 7 + 1
            YearNum = year(AnyDate) + 1
        Case Is < ThisYearStart
            ISOWeekNum = (AnyDate - PreviousYearStart) \ 7 + 1
            YearNum = year(AnyDate) - 1
        Case Else
            ISOWeekNum = (AnyDate - ThisYearStart) \ 7 + 1
            YearNum = year(AnyDate)
    End Select
    If IsMissing(WhichFormat) Then
        Exit Function
    End If
    If WhichFormat = 2 Then
        ISOWeekNum = CInt(Format(Right(YearNum, 2), "00") & _
        Format(ISOWeekNum, "00"))
    End If
    Exit Function
'errorhandling:  Call SaveLogfile("Function ISOWeekNum", Err.Description)
End Function

Class modules:


Option Explicit
' Anrop: SetFiles.init(folder,prefix)
' Returnerar
'   SetFiles.Files(i)   namn
'   SetFiles.noofFiles  antal

Private v_Files() As Variant
Private i_noofFiles As Long

Sub init(lib, prefix)
  Dim fs As New Scripting.FileSystemObject
  i_noofFiles = 0
  If fs.FolderExists(lib) = False Then Exit Sub
  v_Files = GetFilesVar(lib, i_noofFiles, prefix)
End Sub

Public Property Get Files() As Variant
  Files = v_Files
End Property
Public Property Get noOfFiles() As Long
  noOfFiles = i_noofFiles
End Property

Option Explicit
' Anrop: SetFolders.init(folder)
' Returnerar
'   SetFolders.Folder(i)   namn
'   SetFolders.noofFolder  antal

Private v_Folder() As Variant
Private i_noofFolder As Long
Sub init(lib)
  i_noofFolder = 0
  v_Folder = GetFolder(lib, i_noofFolder)
End Sub

Public Property Get Folder() As Variant
  Folder = v_Folder
End Property
Public Property Get noofFolder() As Long
  noofFolder = i_noofFolder
End Property

**gandreso** · 06-28-2016, 06:00 AM

The code continue:


Function LRowFromEnd(col, ActB, actS)
  ' Lastrow from end
  Dim actB1, ActS1
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LRowFromEnd = Cells(Cells.Rows.Count, col).End(xlUp).row
  If LRowFromEnd = 1 Then
   If Cells(1, col).Value = "" Then LRowFromEnd = 0
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function LCol(row, col, ActB, actS)
  ' Last Col , O if first are blank
  Dim actB1, ActS1 As String
  actB1 = ActiveWorkbook.Name
  ActS1 = ActiveSheet.Name
  If ActB <> "" Then Workbooks(ActB).Activate
  If actS <> "" Then Workbooks(actS).Activate
  LCol = Cells(row, col).End(xlToRight).Column
  If LCol = Cells.Columns.Count Then
    If Cells(row, Cells.Columns.Count).Value = "" Then
      If Cells(row, col) <> "" Then LCol = col
      If Cells(row, col) = "" Then LCol = col - 1
    End If
  End If
  Workbooks(actB1).Activate
  Worksheets(ActS1).Activate
End Function
Function TestFileOpen(file)
 ' Test if file is open
 Dim w
 TestFileOpen = False
 For Each w In Workbooks
   ' If File is open
   If w.Name = file Then
      TestFileOpen = True
      Exit Function
   End If
 Next w
End Function
Function closeAllExceptOne(testname)
  ' close all except one
  Dim w
  Application.DisplayAlerts = False
  closeAllExceptOne = False
  For Each w In Workbooks
   ' close if <> testname
   If w.Name <> testname Then
      Workbooks(w.Name).Close
   End If
  Next w
  closeAllExceptOne = True
  ''Application.DisplayAlerts = True
End Function
Function SheetExist(sheet)
 
 Dim w
 SheetExist = False
 For Each w In ActiveWorkbook.Sheets
   If w.Name = sheet Then SheetExist = True
 Next w
End Function
Sub DeleteSheet(sheetName)
    ' Delete sheet before save
    Dim i
    ' Delete Sheet
    If SheetExist(sheetName) = True Then Sheets(sheetName).Delete
End Sub


Sub Rename(sheet, From)
  ' Rename Sheet
  On Error GoTo errorHandling
  Sheets(sheet).Name = n
End Sub
Sub CreateNewSheet(sheet, From, Place)
' Copy new sheet from Sheet
  On Error GoTo Errorhandler
    If Place = "before" Then
      Sheets(From).Copy before:=Sheets(From)
     Else
      Sheets(From).Copy After:=Sheets(From)
    End If
     Sheets("" & From & " (2)").Select
     Sheets("" & From & " (2)").Name = sheet
  Exit Sub
Errorhandler:
Application.ScreenUpdating = True
MsgBox "Problably something wrong with Diagramname. Change The Diagramname!!"
Application.Visible = True
End Sub

Sub InputBoxSub()
    Dim message, Title, default, MyValue
    message = "Enter a value between 1 and 3"    ' Set prompt.
    Title = "InputBox Demo"    ' Set title.
    default = "1"    ' Set default.
    ' Display message, title, and default value.
    MyValue = InputBox(message, Title, default)
    
    ' Use Helpfile and context. The Help button is added automatically.
    MyValue = InputBox(message, Title, , , , "DEMO.HLP", 10)
    
    ' Display dialog box at position 100, 100.
    MyValue = InputBox(message, Title, default, 100, 100)

End Sub
Sub msgboxSub()
    Dim Msg, Style, Title, Help, Ctxt, Response, mystring
    Msg = "Do you want to continue ?"    ' Define message.
    Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
    Title = "MsgBox Demonstration"    ' Define title.
    Help = "DEMO.HLP"    ' Define Help file.
    Ctxt = 1000    ' Define topic
            ' context.
            ' Display message.
    Response = MsgBox(Msg, Style, Title, Help, Ctxt)
    If Response = vbYes Then    ' User chose Yes.
        mystring = "Yes"    ' Perform some action.
    Else    ' User chose No.
        mystring = "No"    ' Perform some action.
    End If
End Sub

Sub wait(sec)
  Dim newhour, newminute, newsecond, waittime
  newhour = Hour(Now())
  newminute = Minute(Now())
  newsecond = Second(Now()) + sec
  waittime = TimeSerial(newhour, newminute, newsecond)
  Application.wait waittime
End Sub

Sub helpdoc()
  ' open helpdoc
   Dim aa
   aa = Shell("Winword " & """" & Folder.MainPath & "\help.doc" & """", 1)
End Sub

Function GetFolderName(strPath As String, Title As String) As String
    ' Open folderdialog
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = Title
        .AllowMultiSelect = False
        .InitialFileName = strPath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolderName = sItem
    Set fldr = Nothing
End Function

Sub createDokWithNoSheets(no, fname)
  ' create workbook with sheetname 1,2,3 ...x
  Dim i As Integer
  Application.DisplayAlerts = False
  Workbooks.Add
  For i = 1 To no
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = i & ""
  Next i
  For i = 1 To Sheets.Count
    If SheetExist("Sheet" & i) = True Then Call DeleteSheet("Sheet" & i)
  Next i
  Worksheets(1).Activate
  If fname <> "" Then ActiveWorkbook.SaveAs fname
End Sub
Function noOfSheetInNotOpenWorkbook(fileName, sheetnames)
    ' check noof sheets
    On Error GoTo errorHandling
    noOfSheetInNotOpenWorkbook = 0
    Dim i As Long
    Dim Shell As Object: Set Shell = CreateObject("WScript.Shell")
    Dim oFSO As Object: Set oFSO = CreateObject("Scripting.FileSystemObject")
    Dim objExcel As Application: Set objExcel = CreateObject("Excel.Application")
    Dim myworkbook As Workbook, worksheetcount As Long
    Set myworkbook = objExcel.Workbooks.Open(fileName)
    On Error Resume Next
    worksheetcount = myworkbook.Worksheets.Count
    noOfSheetInNotOpenWorkbook = worksheetcount
    For i = 1 To worksheetcount
      sheetnames(i) = myworkbook.Worksheets(i).Name
    Next i
    myworkbook.Close
    If Err.Number <> 0 Then
       ' ShowError
        myworkbook.Close False
    End If
errorHandling:
End Function

Option Explicit



Function GetDate(wdate)
    ' Hämtar datum från format ååWvvd
    ' Get date from format
    ' Wdate= 05W18 (Year 05 Week 18 )
    ' Kjell Arby
    Dim i As Long
    Dim sp
    Dim Y As Integer
    Dim M As Integer
    Dim D As Integer
    Dim Data(4)
    On Error GoTo errorHandling
    GetDate = 0 ' If not correct input
    If Len(wdate) <> 5 Then Exit Function
    sp = Split(wdate, "W")
    If UBound(sp) = 0 Then sp = Split(wdate, "w")
    For i = 0 To UBound(sp)
      Data(i) = sp(i)
    Next i
    If Len(Data(1)) < 2 Then Exit Function
    Y = Data(0)
    M = Left(Data(1), 2)
    GetDate = YearStart(Y) + (M - 1) * 7
    Exit Function
errorHandling:
    GetDate = 0 ' If not correct input
End Function

Function YearStart(WhichYear As Integer) As Date
    ' Funktion från Internet
    ' Start Year
    Dim WeekDay As Integer
    Dim NewYear As Date
    'On Error GoTo errorhandling
    NewYear = DateSerial(WhichYear, 1, 1)
    WeekDay = (NewYear - 2) Mod 7
    If WeekDay < 4 Then
        YearStart = NewYear - WeekDay
    Else
        YearStart = NewYear - WeekDay + 7
    End If
    Exit Function
errorHandling:
End Function
Function ISOWeekNum(AnyDate As Date, _
     Optional WhichFormat As Variant) As Integer
    ' Function from Internet
    ' WhichFormat: missing or <> 2 then returns week number,
    '              = 2 then YYWW
    '
    Dim ThisYear As Integer
    Dim PreviousYearStart As Date
    Dim ThisYearStart As Date
    Dim NextYearStart As Date
    Dim YearNum As Integer
 '   On Error GoTo errorhandling
    ThisYear = year(AnyDate)
    
    ThisYearStart = YearStart(ThisYear)
    
    PreviousYearStart = YearStart(ThisYear - 1)
    NextYearStart = YearStart(ThisYear + 1)
    Select Case AnyDate
        Case Is >= NextYearStart
            ISOWeekNum = (AnyDate - NextYearStart) \ 7 + 1
            YearNum = year(AnyDate) + 1
        Case Is < ThisYearStart
            ISOWeekNum = (AnyDate - PreviousYearStart) \ 7 + 1
            YearNum = year(AnyDate) - 1
        Case Else
            ISOWeekNum = (AnyDate - ThisYearStart) \ 7 + 1
            YearNum = year(AnyDate)
    End Select
    If IsMissing(WhichFormat) Then
        Exit Function
    End If
    If WhichFormat = 2 Then
        ISOWeekNum = CInt(Format(Right(YearNum, 2), "00") & _
        Format(ISOWeekNum, "00"))
    End If
    Exit Function
'errorhandling:  Call SaveLogfile("Function ISOWeekNum", Err.Description)
End Function

Class modules:


Option Explicit
' Anrop: SetFiles.init(folder,prefix)
' Returnerar
'   SetFiles.Files(i)   namn
'   SetFiles.noofFiles  antal

Private v_Files() As Variant
Private i_noofFiles As Long

Sub init(lib, prefix)
  Dim fs As New Scripting.FileSystemObject
  i_noofFiles = 0
  If fs.FolderExists(lib) = False Then Exit Sub
  v_Files = GetFilesVar(lib, i_noofFiles, prefix)
End Sub

Public Property Get Files() As Variant
  Files = v_Files
End Property
Public Property Get noOfFiles() As Long
  noOfFiles = i_noofFiles
End Property

Option Explicit
' Anrop: SetFolders.init(folder)
' Returnerar
'   SetFolders.Folder(i)   namn
'   SetFolders.noofFolder  antal

Private v_Folder() As Variant
Private i_noofFolder As Long
Sub init(lib)
  i_noofFolder = 0
  v_Folder = GetFolder(lib, i_noofFolder)
End Sub

Public Property Get Folder() As Variant
  Folder = v_Folder
End Property
Public Property Get noofFolder() As Long
  noofFolder = i_noofFolder
End Property

Makro making Excel stop working

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Makro making Excel stop working

Re: Makro making Excel stop working

Re: Makro making Excel stop working

Re: Makro making Excel stop working

Re: Makro making Excel stop working

Re: Makro making Excel stop working

Re: Makro making Excel stop working

Thread Information

Users Browsing this Thread

Similar Threads

Stop excel from making automatic axis

Comand in Makro not working

Locked cells and makro not working?

stop excel from making links relative

[SOLVED] How can I stop excel from automatically making hyperlinks

SUBTOTAL formulas stop working correctly when new data is added. How do I stop this?

[SOLVED] How do I stop Excel from making copies of files?

Bookmarks

Bookmarks

Posting Permissions