Eli, tällä hetkellä minulla on makro joka tallentaa koko taulukon ja sen välilehdet (sheets) omaan tiedostoonsa. Tähän tapaan:
ActiveWorkbook.SaveAs Filename:="C:\" & Vuosi & "_" & Kuukausi & "_" & Päivä & "_" & Tiedostonimi & "_" & Tieto1 & .xls"
Mitä tuohon pitäisi lisätä että se tallentaisi vain Sheet3 ja Sheet4 tuohon uuteen tiedostoon, ja jättäsisi Sheet1 ja 2 pois?
ActiveWorkbook.SaveAs Filename:="C:\" & Vuosi & "_" & Kuukausi & "_" & Päivä & "_" & Tiedostonimi & "_" & Tieto1 & .xls"
Mitä tuohon pitäisi lisätä että se tallentaisi vain Sheet3 ja Sheet4 tuohon uuteen tiedostoon, ja jättäsisi Sheet1 ja 2 pois?
Vastaukset 7
Vanhimmat
vakiokoodeilla pääset alkuun. Muuta sitä tarvittavaksi.
Sub TallennaSheetit()
Dim Tämätyökirja, Uusityökirja As String
Dim Lkm, Kpl As Integer
Dim Vuosi, Kuukausi, Päivä, Tiedostonimi As String
Application.ScreenUpdating = False
Vuosi = Year(Now())
Kuukausi = Month(Now())
Päivä = Day(Now())
Tiedostonimi = "Tiedot"
Tämätyökirja = ActiveWorkbook.Name
Workbooks.Add
Uusityökirja = ActiveWorkbook.Name
Lkm = 1
For Each sh In ActiveWorkbook.Sheets
sh.Name = Lkm
Lkm = Lkm 1
Next
Kpl = Lkm
Lkm = ActiveWorkbook.Sheets.Count
For Each sh In Workbooks(Tämätyökirja).Sheets
If sh.Name = "Sheet1" Or sh.Name = "Sheet2" Then GoTo Skip
sh.Copy after:=Workbooks(Uusityökirja).Sheets(Lkm)
Lkm = Lkm 1
Skip:
Next
Application.DisplayAlerts = False
Workbooks(Uusityökirja).Activate
For n = 1 To Kpl - 1
Sheets(1).Delete
Next
Sheets(1).Activate
ActiveWorkbook.SaveAs Filename:="C:\" & Vuosi & "_" & Kuukausi & "_" & Päivä & "_" & Tiedostonimi & "_" & "Tieto1" & ".xls"
ActiveWorkbook.Close
End Sub
Sub Tallenna()
Sheets(Array("Sheet2", "Sheet4")).Copy
ActiveWorkbook.SaveAs Filename:="C:\" & Vuosi & "_" & Kuukausi & "_" & Päivä & "_" & Tiedostonimi & "_" & Tieto1 & .xls"
ActiveWindow.Close
End Sub
Keep Exceling
@Kunde
Sheets(Array("Sheet8", "Sheet9")).Copy
tuosta rivistä ei tykännyt.
Onkos työkirjassasi varmasti taulukot nimeltään Sheet8 ja Sheet9? Muuta virhemahdollisuutta en keksi, ellei sitten sinulla ole joku ikivanha versio käytössäsi ja se ei tue tuota Array ominaisuutta.
Tosiaan eihän siellä ton nimisiä taulukoita ollut *läpsii itseään*
Osaisiko Expert excelisti vielä sanoa saisiko tuon tehtyä niin, että Sheet8 jossa on kaksi sivua tekstiä tallentuisi wordin dokumentiksi sivuiksi 1 ja 2. Sitten sheet9 n.5 sivua tallentuisi siitä sivuille 3-8?
Todella paljon kiitoksia avuista.
en tiedä miten excelin ruudukon voisi poistaa näkymästä muuten kuin kikkailemalla. Toisaalta taas kopioimalla excelistä solu kerrallaan on liian hidasta...
Sub ExcelistäWordiin()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim ws As Worksheet
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
End If
On Error GoTo virhe
oWord.DisplayAlerts = wdAlertsNone
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Add
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Sheet8" Or ws.Name = "Sheet9" Then
ws.UsedRange.Copy
oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter
oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=True
Application.CutCopyMode = False
oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not ws.Name = Worksheets(Worksheets.Count).Name Then
With oDoc.Paragraphs(oDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
End If
Next ws
oDoc.Saved = True
oWord.DisplayAlerts = wdAlertsAll
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
virhe:
oWord.DisplayAlerts = wdAlertsAll
oWord.Quit
End Sub
nyt ei näy ruudukkoa...
Sub ExcelistäWordiin()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim ws As Worksheet
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err Then
Set oWord = New Word.Application
End If
On Error GoTo virhe
oWord.DisplayAlerts = wdAlertsNone
oWord.Visible = True
oWord.Activate
Set oDoc = oWord.Documents.Add
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Sheet8" Or ws.Name = "Sheet9" Then
ws.UsedRange.Copy
oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter
oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=True
Application.CutCopyMode = False
oDoc.Paragraphs(oDoc.Paragraphs.Count).Range.InsertParagraphAfter
If Not ws.Name = Worksheets(Worksheets.Count).Name Then
With oDoc.Paragraphs(oDoc.Paragraphs.Count).Range
.InsertParagraphBefore
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdPageBreak
End With
End If
End If
Next ws
For Each aTable In oWord.ActiveDocument.Tables
aTable.ConvertToText wdSeparateByTabs, True
Next aTable
oDoc.Saved = True
oWord.DisplayAlerts = wdAlertsAll
Set oWord = Nothing
Set oDoc = Nothing
Exit Sub
virhe:
oWord.DisplayAlerts = wdAlertsAll
oWord.Quit
End Sub