Taulukon jakaminen tiedostoihin

kymysystä!!! Jos ne 3000 riviä on eri laskentaulukossa (siis välilehdellä, esim Taul1 ja Taul2),niin silloin homma on selvä. Klikkaa hiiren oikella esim. Taul1 valitsinta > sieltä "Siirrä tai kopioi" > "Työkirjaan:" valitse "(uusi kirja)", laita ruksi kohtaan "Tee kopio" > OK. Jne...
Jos et tarkoittanut tätä toimintoa, niin muuta en tuosta kysymyksestä ymmärtänyt. Jos jokainen 3000 rivistä omaksi taulukoksi - HUH HELLETTÄ.

moduuliin...

Sub koe()
Dim Sivunalku As String
Dim Alue As Range
Dim i As Integer
Dim j As Integer
Dim alkuwb As String
Dim uusiwb As String
Dim Sivunvaihto As Integer
Dim Rivit As Long
Dim Polku As String
Dim Sivunkoko As Integer

On Error GoTo virhe
Application.DisplayAlerts = False
Application.ScreenUpdating = False

takaisin:
Sivunkoko = Application.InputBox(" Anna rivienmaara sivulla", "Sivuntulostus", 30, Type:=1)
If Sivunkoko = 0 Then Exit Sub
If Not Sivunkoko > 0 Then
MsgBox "Sinun on annettava 0 suurempi luku!"
GoTo takaisin
End If
Rivit = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.ResetAllPageBreaks
If Rivit > Sivunkoko Then
Sivunvaihto = Int(Rivit / Sivunkoko) 1
For i = 1 To Sivunvaihto
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveSheet.UsedRange.Cells(Sivunkoko * i 1, 1)
Next i
End If
alkuwb = ActiveWorkbook.Name
Sivunalku = "$A$1"

For i = 1 To ActiveSheet.HPageBreaks.Count
uusi = i
If i > 1 Then Sivunalku = ActiveSheet.HPageBreaks(i - 1).Location.Address
j = ActiveSheet.HPageBreaks(i).Location.Row - 1

Workbooks.Add
uusiwb = ActiveWorkbook.Name
Workbooks(alkuwb).Sheets(1).Range(Sivunalku & ":" & "$H$" & Trim$(Str$(j))).Copy _
Destination:=Workbooks(uusiwb).Sheets(1).Range("A1") ' oletus eka taulukko
Polku = "H:\" & uusi & ".xls" 'muuta polkua
ActiveWorkbook.SaveAs Filename:=Polku
ActiveWorkbook.Close
Windows(alkuwb).Activate

Next
' vika sivu lisattava manuaalisesti
If j < Rivit Then
uusi = uusi 1
j = j Sivunkoko
Sivunalku = Range(Sivunalku).Offset(Sivunkoko, 0).Address
Workbooks.Add
uusiwb = ActiveWorkbook.Name
Workbooks(alkuwb).Sheets(1).Range(Sivunalku & ":" & "$H$" & Trim$(Str$(j))).Copy _
Destination:=Workbooks(uusiwb).Sheets(1).Range("A1") ' oletus eka taulukko
Polku = "H:\" & uusi & ".xls" 'muuta polkua
ActiveWorkbook.SaveAs Filename:=Polku
ActiveWorkbook.Close
Windows(alkuwb).Activate
End If
virhe:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


keep Excelling
@Kunde