Keskustelu: Ohjelmointikysymykset: VBA: Excelin csv-tallennus

Dim filepathtemp As String, filepathcsv As String
Dim buffer As String

filepathtemp = "C:\temp\temp.csv"
filepathcsv = "C:\CSV_Files\tiedosto1.csv"

ActiveWorkbook.SaveAs Filename:=filepathtemp, FileFormat:=xlCSV, CreateBackup:=False

Open filepathtemp For Binary Access Read As 1
buffer = Space(LOF(1))
Get #1, , buffer
Close 1
'vaihdetaan pilkut puolipisteeksi
buffer = Replace(buffer, ",", ";")
'vaihdetaan pisteet(desimaalierotin) pilkuiksi
buffer = Replace(buffer, ".", ",")

Open filepathcsv For Binary Access Write As 1
Put #1, , buffer
Close 1

'Formille ListBoxi, 2 TextBoxia, 2 labelia
'checkboxi ja 2 komentonappia.
'säädöt:
'ListBoxi: multiSelect arvoksi=True
'TextBoxit: MaxLength arvoiksi 1

'märitellään julkinen boolean-muuttuja
Public kaikki As Boolean

Private Sub CheckBox1_Click()

  'tutkitaan muuttujan totuusarvo
  Select Case kaikki

    'jos arvo on EPÄTOSI
    Case False

      'asetetaan silmukassa kaikkien taulujen
      'valittu-arvoksi TOSI...
      For i = 0 To ListBox1.ListCount - 1
       ListBox1.Selected(i) = True
      Next i

      '...asetetaan muuttujan totuusarvoksi TOSI
      'ja poistutaan aliohjelmasta.
      kaikki = True: Exit Sub

    'jos arvo on TOSI
    Case True

      For i = 0 To ListBox1.ListCount - 1

      'asetetaan silmukassa kaikkien muiden taulujen
      'paitsi aktiiviseksi määritellyn taulun...
      'valittu-arvoksi EPÄTOSI
        If ListBox1.List(i) <> taulu Then
        ListBox1.Selected(i) = False
        End If
      Next i

      '...asetetaan muuttujan totuusarvoksi EPÄTOSI
      kaikki = False

  End Select

End Sub

Private Sub CommandButton1_Click()

  'Tutkitaan TekstiBoxien sisällöt
  Select Case TextBox1.Text

    'jos vaihtoehtoista erotinmerkkiä
    'ei ole määritelty TextBox'ssa niin
    'eroitimen arvoksi jätettään oletus
    Case Is = ""

      kerotin = ";"

    'muutoin arvoksi asetetaan TextBox1'n teksti
    Case Else

      kerotin = TextBox1.Text

  End Select

  'jne...
  Select Case TextBox2.Text

    Case ""

      terotin = ""

   'jos tietue-erotin on asetettu...
    Case Else

      '...muutujan arvoksi asetetaan TextBox2'n teksti
      terotin = TextBox2.Text

  End Select


  'käydään ListBoxin aktivoidut valinnat
  'silmukassa lävitse...
  For i = 0 To ListBox1.ListCount - 1

   '...jos laskurin osoittaman indeksin
   'mukainen valinta on aktivoitu niin...
   If ListBox1.Selected(i) Then

     '...sijoitetaan kyseisen valinnan
     'arvo merkkijonomuuttujaan...
     taulu = ListBox1.List(i)

     'siirrytään aliohjelmaan:
     maaritaTaulu

     'siirrytään aliohjelmaan:
     csvTallennus

    End If

  Next i

  'siirrytään taphtuma-aliohjelmaan
  '(CommandButton2_Click)
  CommandButton2 = True

End Sub

Private Sub CommandButton2_Click() '(Peruuta)

  'ladataan formi pois muistista
   Unload Me

End Sub


Private Sub UserForm_Activate()

'asetetaan julkiseksi määritetyn
'boolean-muuttujan totuusarvoksi EPÄTOSI
kaikki = False

'Nollataan ListBoxin sisältö
ListBox1.Clear

Dim t As Worksheet

  'Poimitaan silmukassa aktiivisen työkirjan nimet
  For Each t In Worksheets

   With t

    'ja sisällytetään nimet ListBoxin listlle
    ListBox1.AddItem .Name

    If .Name = taulu Then ListBox1.Selected(ListBox1.ListCount - 1) = True

   End With

  Next

End Sub

'määritellään julkiset muuttujat
Public taulu As String, tkirja As String
Public rivit As Long, sarakkeet As Long
Public terotin As String, kerotin As String
Sub auto_open()

  'Avattaessa työkirja:
  'aktivoidaan taulu-indeksin perusteella työkirjan 1. taulu
  Sheets(1).Activate

  'sijoitetaan aktivoidun taulun nimi merkkijonomuuttujaan
  taulu = Sheets(1).Name

End Sub

Public Sub maaritaTaulu()

'määritellään paikallinen merkkijonomuuttuja
 Dim sarake As String

 'sijoitetaan sekä aktiivisen työkirjan että taulu nimi,
 'julkisiksi määriteltyihin merkkijonomuuttujiin
  tkirja = Application.ActiveWorkbook.Name
  If taulu = "" Then taulu = Sheets(1).Name

  Sheets(taulu).Activate

  'estetään näytön turha päivittyminen
  Application.ScreenUpdating = False

  'etsitään taulun viiemisen, jonkin arvon omaavan
  'sarakkeen ja viimeisen, jonkin arvon omaavan rivin
  'perusteella alueen viimeisen solun osoite ja
  'sijoitetaan saatu arvo paikalliseen merkkijono-
  'muuttujaan, poistaen samalla saadusta arvosta
  'dollari-merkit($).
  sarake = Replace(Sheets(taulu).Cells.SpecialCells _
  (xlCellTypeLastCell).Address, "$", "")

  'aktivoidaan aktiivisesta taulusta alue, joka muodostuu
  'taulun ensimmäisen solun (A1) ja edellä etsityn, alueen
  'viimeisen solun muodostamasta alueesta, jolloin voidaan
  'poimia alueen viimeisen rivin sekä sarakkeen sijainti
  'lukuna rivi/sarakelaskureiden indeksien perusteella...
   Sheets(taulu).Range("A1:" & sarake).Select

  '...sijoitetaan saadut arvot,julkisiksi märiteltyihin
  'long-tyyppisiin kokonaislukumuuttujiin
  rivit = Selection.Rows.Count
  sarakkeet = Selection.Columns.Count

  'aktivoidaan ensimmäinen solu...
  Cells(1, 1).Select

  '...ja sallitaan näytön päivittyminen
  Application.ScreenUpdating = True

End Sub

Public Sub csvTallennus()

'alustetaan range-tyyppiset objektit ja merkkijonomuuttuja
Dim tietue As Range
Dim kentta As Range
Dim stringi As String

'avataan työpöydälle tekstitiedosto ja nimetään
'formaatissa 'Työkirja_taulu.csv'

Open Environ("userprofile") & "\Työpöytä\" _
& tkirja & "_" & taulu & ".csv" For Output As #1

'käydään aktiivisessa taulussa läpi aliohjelmassa
'maaritaTaulu määritetyn alueen rivit rivi kerrallaan...
  For Each tietue In Range("A1:A" & rivit)

    With tietue

    'käydään aktiivisessa taulussa, tämän aliohjelman
    'laskuri-indeksin osoittaman rivi/sarakkeindeksin
    'määrittelemät kentät (= solut) lävitse
     For Each kentta In Range(.Cells(1), Cells(.Row, sarakkeet))

      'lisätään paikalliseen merkkijonomuuttujaan kentän
      'sisältö tekstinä + kenttäeroitin
       rivi = rivi & kerotin & kentta.Text

     Next kentta

     'mikäli tietue-erotin on esetettu, lisätään
     'erotin jokaisen rivin (=tietue) loppuun
     If terotin <> "" Then rivi = rivi & teroitin

    'tulostetaan avoimeen tiedostoon, silmukassa muodostettu rivi,
    'jättäen kuitenkin rivin ensimmäinen merkki tulostamatta
    Print #1, Mid(rivi, 2)

    'alustetaan merkkijonomuuttuja uutta silmukan
    'kierrosta varten antamalla sille arvoksi tyhjä.
    rivi = Empty

    End With

  Next tietue

  'suljetaan avoin tiedosto
  Close #1

End Sub

Dim ETunnus As String
Dim VTunnus As String
Dim Tiedosto As String
Dim VSarake As Integer
Dim VRivi As Long
Dim Rivi As Long
Dim Sarake As Integer
Dim Nro As Integer
Const Erotin = ";"

Range("A1").Select
EHanke = ActiveCell.Text
Selection.End(xlDown).Select
VTunnus = ActiveCell.Text

' nimetään tiedosto automaattisesti ensimmäinen tunnus_viimeinen tunnus
Tiedosto = "C:\Siirrot\" +  "ETunnus + "_" + VTunnus + ".csv"

Nro = FreeFile

'haetaan viimeinen sarake ja viimeinen rivi
With ActiveSheet.Cells
    VSarake = .Find("*", [A1], , , xlByColumns, xlPrevious).Column
    VRivi = .Find("*", [A1], , , xlByRows, xlPrevious).Row
End With

' avataan tekstitiedosto kirjoitusta varten
Open Tiedosto For Output As #Nro
' kirjoitetaan rivit sarake kerrallaan erotettuna puolipisteellä
For Rivi = 1 To VRivi
     For Sarake = 1 To VSarake
         Print #Nro, ActiveSheet.Cells(Rivi, Sarake).Value & Erotin;
     Next Sarake
     Print #Nro,
Next Rivi
' suljetaan tiedosto
Close #Nro