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?
Tiettyjen välilehtien tallentaminen
7
534
Vastaukset
- oheisella
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- bulma
Sheets(Array("Sheet8", "Sheet9")).Copy
tuosta rivistä ei tykännyt. bulma kirjoitti:
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.
- bulma
kunde kirjoitti:
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. bulma kirjoitti:
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 Subkunde kirjoitti:
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 Subnyt 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
Ketjusta on poistettu 0 sääntöjenvastaista viestiä.
Luetuimmat keskustelut
Kuvat! Dannyyn liitetty Helmi Loukasmäki, 22, on puhjennut naisena kukkaan - Some sekoaa: "Sä..."
Ooo, kaunis aikuinen nainen Helmistä on kasvanut siinä yli 80-vuotiaan Dannyn rinnalla! Katso uudet kuvat: https://ww685623- 613764
Suodatinpussin kastelemalla saa parempaa kahvia
Kokeilin niksiä ja kyllä tämä kahvi on parempaa nyt. Ei lainkaan maistu paperiselta. Huljuttelee hanan alla suppiloa pap1532755Tidätkö nainen
että suoraan sanottuna v.tut.aa että pääsit näin lähelle minua. Ei olisi oikeasti aikaa tähän mutta silti aina välillä o1052196Mikä on kaivattusi etunimi?
Otsikossa siis on kysymys eriteltynä. Vain oikeat vastaukset hyväksytään.1092045Oho! Arja Koriseva paljastaa TTK:n ekasta suorasta lähetyksestä: "On vähän ärsyttävä yhtälö!"
Upea Arja Koriseva! Tsemppiä haasteelliseen tilanteeseen! Lue lisää: https://www.suomi24.fi/viihde/oho-arja-koriseva-211329Onkohan sinulla kaikki hyvin?
Nyt vähän sellainen outo tunne tuli. Sinun asiasi niin ei minulle toki tarvitse kertoa. Kunhan mietin...381297En kestä katsoa
Sitä miten sinusta on muut kiinnostuneita. Olen kateellinen. Siksi pitäisi lähteä pois961278Huikeeta, mahtavaa, ihan mielettömän upeeta
Me ostettiin talo Espanjasta. Tosin saadaan käyttää sitä vain muutama viikko vuodessa kun on monta muutakin ostajaa! M1951232- 1731146