Keskustelu: Ohjelmointikysymykset: VBA-koodilla Excel tiedostosta kopiointi toiseen exceliin

Pallomasi [01.12.2011 12:56:07]

eli tarkoitus on sellainen, että avaan excel-tiedoston, jossa on välilehti nimellä YHTEENVETO. se sisältää satunnaisen määrän tekstiä ja numeroarvoja (esim. alue A1:E20). Tämän alueen kopioiminen leikepöydälle onnistuu, mutta liittäminen uuteen exceliin (MASTER.xls, välilehti "Valilehti1") ei onnistu. Toiminto aktivoidaan YHTEENVETO-välilehdellä olevasta napista (Painike2).

virhe "Substrict out of range" tulee rivillä

With ThisWorkbook.Sheets("Valilehti1")

Olen kokeillut joitain muitakin konsteja tuohon pasteamisosuuteen mutta erroria pukkaa aina.

alla käytetty koodi.

Option Explicit
Global objMaster        As New Workbook
Global VipaRivi         As Long
Global EkaRivi          As Long
Global VipaSarake       As Integer
Global EkaSarake        As Integer

Sub Painike2_Napsautettaessa()
Call KopioiYhteenvetoMasteriin
End Sub

Public Sub KopioiYhteenvetoMasteriin()
Dim maxTietueExcelYhteenveto    As String
Dim maxTietueExcelMaster        As Integer
Dim msg                         As String
Dim laskun_polku                As String
On Error GoTo virhe ' virheen sattuessa hyppää lasku_virhe -kohtaan
    'Application.ScreenUpdating = False
    ' etsitään eka rivi jossa tekstiä
    EkaRivi = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByRows).Row
      EkaRivi = EkaRivi + 1 ' lisätään yksi, niin ei tule otsikkorivi mukaan
    ' etsitään eka sarake jossa tekstiä
    EkaSarake = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByColumns).Column
    ' etsitään vipa rivi jossa tekstiä
    VipaRivi = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row
    ' etsitään vipa sarake jossa tekstiä
    VipaSarake = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByColumns).Column

    'Kopioidaan alue muuttujien avulla
    With ThisWorkbook.Sheets("YHTEENVETO")
        Range(Cells(EkaRivi, EkaSarake), Cells(VipaRivi, VipaSarake)).Copy
    End With

    polku = "C:\Testi\MASTER.xls" ' MASTER-excelin sijainti
    Set objMaster = Workbooks.Open(polku)
    objMaster.Sheets("Valilehti1").Activate
    maxTietueExcelMaster = ActiveSheet.UsedRange.Rows.Count ' laskee vipan käytetyn rivin

    With ThisWorkbook.Sheets("Valilehti1")
        .Range(maxTietueExcelMaster, 1).PasteSpecial Paste:=xlPasteValues
    End With

    'Application.ScreenUpdating = True
    objMaster.SaveAs (polku)
    objMaster.Close
    Set objMaster = Nothing

    Exit Sub

virhe:
    If Err.Number <> 0 Then
        msg = "Virhe numero " & Str(Err.Number) & " tuli! " _
            & "(" & Err.Source & ")" & Chr(13) & Err.Description & Chr(13) & Chr(13) & "OTA YHTEYS KOODARIIN"
        MsgBox msg, , "Error", Err.HelpFile, Err.HelpContext
        objMaster.Close
        'objMaster.Close SaveChanges:=False
        Set objMaster = Nothing
    End If
End Sub

Grez [01.12.2011 13:35:58]

Pallomasi kirjoitti:

virhe "Substrict out of range" tulee rivillä
With ThisWorkbook.Sheets("Valilehti1")

Vika on siinä, että Thisworkbookilla ei ole välilehteä Valilehti1. Oletko varma, että ThisWorkbook on se työkirja, minkä kuvittelet sen olevan?

Vai pitäisikö ThisWorkbook tilalla olla objMaster

Pallomasi [01.12.2011 15:05:04]

Tuon ThisWorkbookin vaihtaminen objMasteriksi auttoi jonkin verran, kiitos siitä Grezin neuvolle, mutta nyt tulee virhe "application-defined or object-defined error" rivillä

.Range(maxTietueExcelMaster, 1).PasteSpecial Paste:=xlPasteValues

Kokeilin seuraavanlaisella pätkällä mutta erroria "Luokan Range menetelmä PasteSpecial epäonnistui"

.Range("A2").PasteSpecial Paste:=xlPasteAll, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False

Testailin vähän ja copy-paste onnistuu kyllä MASTER.xls sisällä välilehti1:ltä esim. välilehti 2:lle, mutta se ei hyödytä tässä tapauksessa.

Grez [01.12.2011 16:10:02]

No onko niitä oikeasti pakko pyörittää leikepöydän kautta? Varsinkin jos haluat kopioida pelkät arvot, niin mikset vaan koodilla kopioi tyyliin:

kohdesolu.Value = lähdesolu.Value

Jos se pitää saada lisäksi leikepöydälle, niin voithan tehdä kopion kuten nyttenkin ja lisäksi kopioida ohjelmallisesti.

neau33 [02.12.2011 10:50:58]

Moi Pallomasi!

testaa oheisen viritelmän toimintaa...

Private Sub CommandButton1_Click()

    Dim thiswk As Workbook

    If Not WorkbookExists("MASTER.xls") Then
        If Dir("C:\Testi\MASTER.xls") <> "" Then
            Application.ScreenUpdating = False
            Set thiswk = ThisWorkbook
            Workbooks.Open "C:\Testi\MASTER.xls"
            thiswk.Activate: Set thiswk = Nothing
            Application.ScreenUpdating = True
        Else
           Application.ScreenUpdating = False
           Set thiswk = ThisWorkbook: Workbooks.Add
           ActiveWorkbook.Sheets("Taul1").Name = "Valilehti1"
           ActiveWorkbook.SaveAs "C:\Testi\MASTER.xls"
           thiswk.Activate: Set thiswk = Nothing
           Application.ScreenUpdating = True
       End If
    End If

    Dim ekarivi, vikarivi, ekasarake, vikasarake, osoite() As String

    osoite = Split(Sheets("YHTEENVETO").Cells.SpecialCells( _
    xlCellTypeLastCell).Address, "$")
    vikarivi = CLng(osoite(2)): Dim ColumnAddress As String
    ColumnAddress = "$" & osoite(1) & ":$" & osoite(1)
    vikasarake = Range(ColumnAddress).Column
    ekarivi = vikarivi: ekasarake = vikasarake: Erase osoite

    For i = 1 To vikarivi
        If Application.CountA(Sheets( _
        "YHTEENVETO").Rows(i).EntireRow) <> 0 Then
            ekarivi = i: Exit For
        End If
    Next

    For i = 1 To vikasarake
        If Application.CountA(Sheets( _
        "YHTEENVETO").Columns(i).EntireColumn) <> 0 Then
            ekasarake = i: Exit For
        End If
    Next

    Dim kohderivi
    kohderivi = Workbooks("MASTER.xls").Sheets( _
    "Valilehti1").Cells.SpecialCells( _
    xlCellTypeLastCell).Row

    If Application.CountA(Workbooks( _
    "MASTER.xls").Sheets("Valilehti1"). _
    Rows(kohderivi).EntireRow) <> 0 Then
        kohderivi = kohderivi + 1
    End If

    Sheets("YHTEENVETO").Range( _
    Sheets("YHTEENVETO").Cells(ekarivi, ekasarake), _
    Sheets("YHTEENVETO").Cells(vikarivi, vikasarake)).Copy _
    Workbooks("MASTER.xls").Sheets( _
    "Valilehti1").Range("A" & CStr(kohderivi))

    Application.ScreenUpdating = False
    Workbooks("MASTER.xls").Save
    'Workbooks("MASTER.xls").Close
    Application.ScreenUpdating = True

End Sub

Function WorkbookExists(ByVal wkname As String) As Boolean

    For Each Workbook In Application.Workbooks
        With Workbook
            If .name = wkname Then
                WorkbookExists = True: Exit Function
            End If
        End With
    Next

    WorkbookExists = False

End Function

Pallomasi [22.12.2011 14:32:42]

Kiitos Nea, koodisi auttoi eteenpäin.
Nyt on vain sellainen ongelma että koodi kopioi solussa olevan kaavan muutamasta solusta, jolloin solu näyttää 0€. Eli hiukan selvennän asiaa:
kopioitavia soluja rivillä on: nimi, nro, pvm, summa, summaEiALV
muuten kopioituu oikein, mutta summa- ja summaEiALV -kentät näyttää 0€, kun noihin soluihin kopioituu solussa oleva kaava kopioitavasta taulukosta.
alla koodi jolla kopiointi tapahtuu.

Sheets("YHTEENVETO").Range(Cells(ekarivi, ekasarake), Cells(viparivi, vipasarake)).Copy _
Workbooks("MASTER.xls").Sheets( _
valilehtiNimi).Range("A" & CStr(kohderivi))

tarkoituksena on siis saada kopioitua vain solun arvo (value) ilman mitään kaavahärpäkkeitä takanaan.
kokeilin käyttää SpecialCells metodeja mutta en saanut pelittämään oikein ja ymmärrys loppui.

neau33 [22.12.2011 23:03:49]

Moi taas Pallomasi!

kokeile seuraavin muutoksin...

'---------------- vaihda nämä rivit ---------------------
'Sheets("YHTEENVETO").Range( _
'Sheets("YHTEENVETO").Cells(ekarivi, ekasarake), _
'Sheets("YHTEENVETO").Cells(vikarivi, vikasarake)).Copy _
'Workbooks("MASTER.xls").Sheets( _
'"Valilehti1").Range("A" & CStr(kohderivi))
'--------------------------------------------------------

'---------------- näihin riveihin -----------------------
Dim solu, alue As Range

Set alue = Sheets("YHTEENVETO").Range( _
Sheets("YHTEENVETO").Cells(ekarivi, ekasarake), _
Sheets("YHTEENVETO").Cells(vikarivi, vikasarake))

For Each solu In alue
    Workbooks("MASTER.xls").Sheets( _
    "Valilehti1").Cells(kohderivi + solu.Row - ekarivi, _
    solu.Column + 1 - ekasarake).Value = solu.Value
Next

Set alue = Nothing
'--------------------------------------------------------

Pallomasi [28.12.2011 12:44:42]

Tuhannet kiitokset Nea, nyt kaikki toimii niinkuin pitääkin :)

-Pallomasi

Sivun alkuun

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät

Kilpailu