Keskustelu: Ohjelmointikysymykset: VBA: Excel ja ulkoiset tiedot vol 2

Sub TuoTiedot()

    Application.ScreenUpdating = False

    Dim fd As FileDialog, _
    thisPath As String, _
    thisName As String, _
    xlFile As Variant, _
    FullPath As String

    thisPath = ActiveWorkbook.FullName
    thisName = ActiveWorkbook.Name

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd
        .AllowMultiSelect = False
        .Filters.Add "Laskentataulukot (*.xls)", "*.xls", 1
        .FilterIndex = 1
        If .Show = -1 Then
           For Each xlFile In .SelectedItems
              FullPath = xlFile
           Next
        Else
           Exit Sub
        End If
    End With

    Set fd = Nothing

    Dim wk As Workbook
    For Each wk In Workbooks
        With wk
            If .FullName = FullPath Then
                Exit Sub
            End If
        End With
    Next

    Workbooks.Open (FullPath)
    Dim thatName As String
    thatName = ActiveWorkbook.Name

    Workbooks(thatName).Sheets("Taul1"). _
    Range("A1:C20").Copy Destination:= _
    Workbooks(thisName).Sheets("Taul1").Range("A1")
    Workbooks(thatName).Close

    Application.ScreenUpdating = True

End Sub

'Taul1
Private Sub CommandButton1_Click()
    TuoTiedot
End Sub

Sub TuoTiedot()

    Application.ScreenUpdating = False

    Dim fd As FileDialog, _
    csvFile As Variant, _
    fullPath As String

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd
        .AllowMultiSelect = False
        .Filters.Add "Laskentataulukot (*.csv)", "*.csv", 1
        .FilterIndex = 1
        If .Show = -1 Then
           For Each csvFile In .SelectedItems
              fullPath = csvFile
           Next
        Else
           Exit Sub
        End If
    End With

    Set fd = Nothing

    Dim csvData As String
    Open fullPath For Input As #1
    csvData = Input$(LOF(1), 1): Close #1
    Dim rowArray() As String

    '*** HUOM! Excel käyttää oletuksen omissa csv-tiedostoissaan
    'rivierottimena merkkiyhdistelmää vbCrLf = Chr(13) & Chr(10)
    Dim rowDelim As String
    rowDelim = vbCrLf

    If InStr(csvData, vbCrLf) = 0 Then
       If InStr(csvData, vbLf) > 0 Then
          rowDelim = vbLf
       Else
         If InStr(csvData, vbCr) > 0 Then
            rowDelim = vbCr
         End If
       End If
    End If

    rowArray = Split(csvData, rowDelim)

    On Error Resume Next
    arrayRows = UBound(rowArray)

    If Err <> 0 Then

       Err.Clear
       On Error GoTo 0
       ReDim rowArray(0)
       rowArray(0) = csvData

       Dim tmpArray() As String

       '*** ............................
       tmpArray = Split(rowArray(0), ";")

       On Error Resume Next
       arrayCols = UBound(tmpArray)

       If Err <> 0 Then
          Err.Clear
          On Error GoTo 0
          MsgBox ("Tiedosto ei sisällä Excel-yhteensopivaa dataa")
          Erase tmpArray: csvData = "": Exit Sub
       End If

       Erase tmpArray: csvData = ""

    End If

    Dim pos As Integer
    pos = InStrRev(fullPath, "\")
    Dim sheetName As String
    sheetName = Right(fullPath, Len(fullPath) - pos)
    sheetName = Replace(sheetName, ".", "_")
    Sheets.Add After:=Worksheets(Worksheets.Count)
    Sheets(Sheets.Count).Name = sheetName
    Dim colArray() As String

    For i = LBound(rowArray) To UBound(rowArray)

        '*** ja sarake-erottimena puolipistettä
        colArray = Split(rowArray(i), ";")

        On Error Resume Next
        For j = LBound(colArray) To UBound(colArray)
           '***HUOMIOI MUUTOS!!!
           'Sheets(sheetName).Cells(i + 1, j + 1).Value = colArray(j)
           Sheets(sheetName).Cells(i + 1, j + 1).Formula = colArray(j)
        Next j
        If Err <> 0 Then
            Err.Clear
            On Error GoTo 0
        End If
        Erase colArray

    Next i

    Erase rowArray

    'Sheets("Taul1").UsedRange.Clear
    Sheets(sheetName).UsedRange.Copy _
    Destination:= Sheets("Taul1").Range("A1")
    Sheets(sheetName).Select
    Application.DisplayAlerts = False
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("Taul1").Activate

End Sub

Private Sub CommandButton2_Click()

    If Not UserForm1.Visible Then
        UserForm1.Show
        SendKeys ("{ESC}")
    End If

    If shName <> "" Then
        If Sheets(shName).UsedRange.Rows.Count > 1 _
        Or Sheets(shName).UsedRange.Columns.Count > 1 Then
            SaveAsCvs
        Else
            MsgBox "Ei mitään tallennettavaa"
        End If
    End If

End Sub

Public Sub SaveAsCvs()

   Dim basePath As String, fullPath As String
   Dim colData As String, xlCell, lastCol As Integer
   lastCol = Sheets(shName).UsedRange.Columns.Count
   basePath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")
   fullPath = basePath & shName & "_csv.csv"

   Open fullPath For Output As #1

   For Each xlCell In Sheets(shName).UsedRange.Cells
      colData = colData & xlCell.Formula
      If xlCell.Column < lastCol Then
         colData = colData & ";"
      Else
         Print #1, colData
         colData = ""
      End If
   Next

   Close #1

End Sub

'UserForm1
Private Sub UserForm_Activate()

    Me.Caption = "Tallenna csv-muodossa"
    Dim sh As Worksheet
    ComboBox1.Style = fmStyleDropDownList
    ComboBox1.Clear
    ComboBox1.AddItem ""

    For Each sh In Worksheets
        With sh
            ComboBox1.AddItem .Name
        End With
    Next

    shName = ""
    ComboBox1.ListIndex = 0

End Sub

Private Sub ComboBox1_Change()

    If ComboBox1.ListIndex > 0 Then
        shName = ComboBox1.List(ComboBox1.ListIndex)
        Unload Me
    Else
        shName = ""
    End If

End Sub