Abteilung Grünland und Futterbau/Ökologischer Landbau

Excel

 

Private Sub CommandButton1_Click()

'Set dates = CreateObject("System.Collections.ArrayList")
    Set dates = New Collection
    dates.Add CDate("30-8-2009")
    dates.Add CDate("1-9-2009")
    dates.Add CDate("2-9-2009")

    Set vs = getSimValues("YLAI", dates)

    For Each v In vs
Debug.Print v & " " & vs(v)
    Next
Debug.Print
    Set vs = getSimValues("GLAI", dates)

    For Each v In vs
Debug.Print v & " " & vs(v)
    Next
Debug.Print

    Set xs = getObsValues("Measure Plant", "BEXP_S1_FF1_NF1_N1", "LAI")

    For Each x In xs
Debug.Print "ok " & x & " " & xs(x)
    Next
Debug.Print

End Sub


Function getSimValues(prop As String, ByVal dates As Collection) 
  As Scripting.Dictionary
    Set dict = New Scripting.Dictionary
    Set wb = Workbooks.Open(FileName:="field0.xls")
    datcol = Application.Match("date", Worksheets("field0").Rows(1), 0)
    propCol = Application.Match(prop, Worksheets("field0").Rows(1), 0)

    For Each dat In dates
        intRow = Application.Match(CDbl(dat), _ 
                  Worksheets("field0").Columns(CInt(datcol)), 0)
        dict.Add dat, Worksheets("field0").Cells(intRow, propCol).Value
    Next
    wb.Close
    Set getSimValues = dict
End Function

Function getObsValues(table As String, id As String, prop As String) 
  As Scripting.Dictionary
    Set dict = New Scripting.Dictionary

    Dim dbe As Object    ' As DAO.DBEngine
    Dim db As Object   ' As DAO.Database
    Dim rs As Object     ' AS DAO.Recordset
    Dim dbfile As String

    dbfile = "BiogasExpert.mdb"

    'Set dbe = CreateObject("DAO.DBEngine.36")   ' Acc2000-2003
    Set dbe = CreateObject("DAO.DBEngine.120")   ' Acc2007+
    Set db = dbe.OpenDatabase(dbfile)

    Dim sql As String
    sql = "select date, avg(" & prop & ") as Y" & _
          " from [" & table & "]" & _
          " where id='" & id & "' and 'fractionid=tot' and " & prop & _
                        " is not null " & _
          " group by date "

Debug.Print sql

    Set rs = db.Openrecordset(sql)
    If Not rs.EOF Then rs.MoveFirst  'rs.recordcount
    
    Do While Not rs.EOF
'Debug.Print rs!Date & " " & rs!y
        dict.Add CDate(rs!Date), CDbl(rs!y)
        rs.MoveNext
    Loop
    
    rs.Close
    db.Close
    Set getObsValues = dict
End Function

IO (INI- und Excel-Dateien, Datenbanken (Access))

' INI Dateien

Function GetFile(ByVal FileName)
    Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
    GetFile = FS.OpenTextFile(FileName).ReadAll
End Function

Function WriteFile(ByVal FileName, ByVal Contents)
    Dim FS: Set FS = CreateObject("Scripting.FileSystemObject")
    Dim OutStream: Set OutStream = FS.OpenTextFile(FileName, 2, True)
    OutStream.Write Contents
End Function  

Sub WriteINIString(Section, KeyName, Value, FileName)
    Dim INIContents, PosSection, PosEndSection

    INIContents = GetFile(FileName)
    PosSection = InStr(1, INIContents, "[" & Section & "]", vbTextCompare)

    If PosSection > 0 Then
        PosEndSection = InStr(PosSection, INIContents, vbCrLf & "[")
        If PosEndSection = 0 Then PosEndSection = Len(INIContents) + 1

        Dim OldsContents, NewsContents, Line
        Dim sKeyName, Found

        OldsContents = Mid(INIContents, PosSection, PosEndSection - PosSection)
        OldsContents = Split(OldsContents, vbCrLf)

        sKeyName = LCase(KeyName & " ")

        For Each Line In OldsContents
            If LCase(Left(Line, Len(sKeyName))) = sKeyName Then
                lPos = InStr(Line, "//")
                If lPos > 0 Then Comment = Mid(Line, lPos)
                Line = KeyName & " " & Value & "; " & Comment
                Found = True
            End If
            NewsContents = NewsContents & Line & vbCrLf
        Next

        If IsEmpty(Found) Then
            NewsContents = NewsContents & KeyName & " " & Value
        Else
            NewsContents = Left(NewsContents, Len(NewsContents) - 2)
        End If

        INIContents = Left(INIContents, PosSection - 1) &  NewsContents & _ 
                         Mid(INIContents, PosEndSection)

    Else
        If Right(INIContents, 2) <> vbCrLf And Len(INIContents) > 0 Then
            INIContents = INIContents & vbCrLf
        End If
        INIContents = INIContents & "[" & Section & "]" & _ 
                        vbCrLf & KeyName & " " & Value
    End If

    WriteFile FileName, INIContents
End Sub


Function GetINIString(Section, KeyName, Default, FileName)
    Dim INIContents, PosSection, PosEndSection, sContents, Value, Found

    INIContents = GetFile(FileName)

    PosSection = InStr(1, INIContents, "[" & Section & "]", vbTextCompare)

    If PosSection > 0 Then
        PosEndSection = InStr(PosSection, INIContents, vbCrLf & "[")
        If PosEndSection = 0 Then PosEndSection = Len(INIContents) + 1

        sContents = Mid(INIContents, PosSection, PosEndSection - PosSection)

        If InStr(1, sContents, vbCrLf & KeyName & " ", vbTextCompare) > 0 Then
            Found = True
            sFrom = sContents
            Dim PosB: PosB = InStr(sFrom, vbCrLf & KeyName & " ")

            PosB = PosB + Len(KeyName) + 2
            Dim PosE As Integer           
            If PosE = 0 Then PosE = InStr(PosB, sFrom, ";")
            If PosE = 0 Then PosE = InStr(PosB, sFrom, "//")
            If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
            If PosE = 0 Then PosE = Len(sFrom) + 1

            Value = Application.WorksheetFunction.Clean(Mid(sFrom, PosB, PosE - PosB))
            Value = Trim(Value)
            'Debug.Print "result " + Value
        End If
    End If

    'Debug.Print "Value " & Value
    If IsEmpty(Found) Then Value = Default
    GetINIString = Value
End Function


    Dim ReadFile As String
    Dim rcount As Long
    Dim fso As Object
    Dim TextDat As Object

    ReadFile = StandardCrop.dat"

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set TextDat = fso.OpenTextFile(ReadFile, 1, False)

    Dim a() As String

    Do While TextDat.AtEndOfStream <> True
        rcount = rcount + 1
        Line = TextDat.readline
        a = Split(Line, "//")
        Comment = "//"
        For i = LBound(a) + 1 To UBound(a)
            Comment = Comment & a(i)
        Next
    Loop

    TextDat.Close

    s = GetINIString("Maize", "Height", "0", "Standard.dat")
    Call WriteINIString("Maize", "Height", s + 1, "Standard.dat")

Debug.Print "wert " & s         
  
    'datei.writeline "Hallo Welt"
    'datei.Close

    'datei.write "Hallo "
    'datei.write "Welt" & vbCrLf  ' analog zum obigen Beispiel
    'datei.writeblanklines 5

' Excel Dateien

    Dim sourceSheet As Worksheet
    Dim destSheet As Worksheet
    Dim wb As Workbook

    Dim outputfilename As String
    Dim outputsheetname As String
      
    Workbooks.Open FileName:="field0.xls"
    Set sourceSheet = Worksheets("field0")
   
    Worksheets("field0").Cells.Copy    
   
   ' search string in row
Debug.Print Application.Match("date", Worksheets("field0").Rows(1), 0)    
Debug.Print Application.Match("LAI", Worksheets("field0").Rows(1), 0)
          
    Set wb = ActiveWorkbook

    ThisWorkbook.Activate
    Set destSheet = Sheets("SS")
    destSheet.Cells.Paste
    ActiveWorkbook.Save

    wb.Close   


' Datenbanken, MS Access
    
    Dim dbe As Object    ' As DAO.DBEngine
    Dim db  As Object    ' As DAO.Database
    Dim rs As Object     ' AS DAO.Recordset
    Dim dbfile As String
    
    dbfile = "Expert.mdb"
   
    'Set dbe = CreateObject("DAO.DBEngine.36")   ' Acc2000-2003
    Set dbe = CreateObject("DAO.DBEngine.120")   ' ab Acc2007
    Set db = dbe.OpenDatabase(dbfile)
   
    Dim sql As String
    sql = "select * from [Measure Plant]"
    
    Set rs = db.Openrecordset(sql)
     
    If Not rs.EOF Then rs.MoveFirst
    'rs.recordcount
    Do While Not rs.EOF        
        'Debug.Print "Date: " & rs![Date] & " " & rs!LAI & " " & _ 
                           rs!DM & " " & rs!n      
        rs.MoveNext       
    Loop
    
   rs.Close
   db.Close
   Set rs = Nothing
   Set db = Nothing
   Set dbe = Nothing

Suchen und Ersetzen

On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
Set objArgs = WScript.Arguments
Set fd = fso.GetFolder(objArgs(0))
Set fc = fd.Files
For Each f1 in fc
f1.Name = Replace(f1.Name, "Ä", "Ae")
f1.Name = Replace(f1.Name, "Ö", "Oe")
f1.Name = Replace(f1.Name, "Ü", "Ue")
f1.Name = Replace(f1.Name, "ä", "ae")
f1.Name = Replace(f1.Name, "ö", "oe")
f1.Name = Replace(f1.Name, "ü", "ue")
Next
WScript.Echo "Änderungen abgeschlossen!"
WScript.Quit

Speichern als  "UmlauteEntf.vbs" in C:\Users\Dein Benutzername\AppData\Roaming\Microsoft\Windows\SendTo. Dann im Windows Explorer mit der rechten Maustaste auf den Ordner, im Kontextmenü "Senden an..." UmlauteEntf.vbs, dann werden alle Dateinamen im Ordner mit Umlauten geändert.

 

Aktuelles

Lehre

Forschung und Publikationen

Links

  • Variationsstatistik Ethik Fachschaft Kompetenzzentrum Milch Abreifeprognose Silomais