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

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

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

'---------------- 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
'--------------------------------------------------------