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
bulma
7
729
Vastaukset 7
- 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
- 1652785
- 561159
Perhoseni (miehelle)
Miksi et usko, että mun rakkaus sinuun on aitoa ja vilpitöntä? Tai että se oli jo silloin? Miksi ajattelet, ettet ole r160947Myönnetään, tunnen lämpimiä tunteita kohtaasi
Vaikutat tosin liian hyvältä ollaksesi totta. Komeita miehiä on maailma pullollaan mutta sinussa on jotain.....57897- 4839
- 83787
Onko Sofia jälleen jätetty?
Moni asia viittaisi siihen, että hän on jälleen sinkku.173780Rekat seisovat dieselin hinnan takia . Ala ei kestä tällaista hintatasoa, sanoo yrittäjä .
EU:n kallein diesel on kova paikka kuljetusalalle. Ajoja on jätetty ajamatta kannattavuusongelmien vuoksi, sanoo alan e180727Totta on asia. Jeffrey Cohen on jättänyt Sofian.
Vaimon viesti on paljastanut totuuden.201693- 6674
- 59666
- 53657
- 67646
- 55608
Mies, näetkö minut myös
Seksuaalisena ihmisenä ja naisena? Haluatko minua seksuaalisesti? Vai olenko mielestäsi tyttönen?21588Nainen, mitä mieltä olet kodittomista?
Ja heistä jotka eivät kykene huolehtimaan asioistaan, itsestään eikä terveydestään? Miten heidän kanssaan tulisi toimia?123555Kuinkahan monen
Naisen puolisoa olet nainen vikitellyt ja eron aiheuttanut? Toivottavasti karma on ku*sut muroihisi useamman kuin kerran66539Voiko se ikinä toimia
Voiko meistä ikinä tulla mitään? Näin kauan aikaa on kulunut ja mitään ei tapahdu... En usko, että sinä mietit minua het32538- 34517
- 55508