Kopiointi muista työkirjoista

laakavaaka20.2.2018 klo 2.36

Moi

Kansiossa on samanlaisella rakenteella useita kymmeniä työkirjoja, joista olisi tarkoitus päivittää uusi työkirja, eli vanha työkirja/uusi välilehti. Sitä varten pitäisi kopioida kustakin työkirjasta solualueita uuteen työkirjaan omille välilehdilleen.

Kopioitavat solualueet
C20
B23:I26
B29:I34
B37:I42
B45:I48
B51:I54
B57:I60
B63:I66
B69:I72
B75:I80
B83:I86
B89:I92
B95:I100

Kopioidaan uuteen työkirjaan
- välilehden nimi tulee solusta (C20)
- solualueet alekkain yhteenpötköön alkaen B5:I5 (B23:I26)

Kiitti

19731

Äänestä

Vastaukset 19

Vanhimmat

Tämmöinen22.2.2018 klo 8.22

Tämä moduliin siinä uudessa Excel-tiedostossa. Voi viedä aikaa, jos tiedostoja on kymmeniä.

Sub Työkirjat_yhteen()

Dim tämä, wb As Workbook
Dim ws As Worksheet
Dim Löytö, nn, e As String
Dim kopioitava As Range
Dim i, r, n As Integer
Dim alue As Variant
alue = Array("B23:I26", "B29:I34", "B37:I42", "B45:I48", "B51:I54", "B57:I60", _
             "B63:I66", "B69:I72", "B75:I80", "B83:I86", "B89:I92", "B95:I100")

Const polku = "C:/temp/temp/"       ' Tähän oikea hakemisto
Const Haettavat = polku & "*.xlsx"  ' .. ja tiedostotunnus

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set tämä = ActiveWorkbook
    Löytö = Dir(Haettavat) ' Ensimmäinen
    Do Until Löytö = ""

        Set wb = Workbooks.Open(polku & Löytö)
        Set ws = wb.Worksheets(1)
        DoEvents
        n = 0
        nn = ws.Range("C20")

On Error GoTo err:
Yritys:
        tämä.Sheets(1).Name = nn

        r = 5
        For i = 0 To UBound(alue)
            ws.Activate
            Range(alue(i)).Select
            Selection.Copy
            tämä.Activate
            Cells(r, 2).Select
            ActiveSheet.Paste

            r = Cells(Rows.Count, "B").End(xlUp).Row 1
        Next i

        wb.Close
        Löytö = Dir ' Seuraava
        If Löytö <> "" Then tämä.Sheets.Add
    Loop

    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
Exit Sub

err:
    If err.Number = 1004 Then
        n = n 1
        nn = ws.Range("C20") & "(" & n & ")"
        MsgBox ("tuplanimi")
        Resume Yritys
    Else
        MsgBox (err.Number & " " & err.Description)
    End If
End Sub

Äänestä

laakavaaka22.2.2018 klo 20.27

Moikka

Fiksaisitko vielä muutaman kohan. Eka alue pitäs tulostuu riveille 5-8 ja toka jatketaan sen perään riviltä 9 lähtien. Nyt tulostaa tokan alueen riviltä 6 alkaen, eli uus alue aina yhden rivin alempaa kuin edellisen eka rivi.

Entä saaks helposti niin, että kopioitavien alueiden muotoilu säilys kohteen mukaan. Toimiiko muuten fiksaamatta, jos noitten alueiden rivi- ja sarakemäärää tai ryhmien määrää tarttee muuttaa, eli onko muunneltavissa.

No nii, eipä tässä ite voi muuta kuin toivoo ja kiitellä, joten kiitti taas.

Äänestä

laakavaaka23.2.2018 klo 2.41

Nyt tulostaa rivit oikein. Syy oli tos vikarivin määrittelyssä B-sarakkeesta. Se on pvm-sarake ja siin ei ole merkintää joka rivillä. Kun ottaa sen C-sarakkeesta niin johan pelittää. Nyt näyttää ainakin tällä hetkellä kaikin puolin hyvälle

Äänestä

laakavaaka23.2.2018 klo 14.48

Moikka taas

Saisko tota muutettuu silleen, et se avais vaikka piiilotetun välilehen lomakkeeks ennen kopsauksii. Sit jos viilaisit tuota tuplanimi ilmoitusta siten, että mahollisen ilmotuksen jälkeen vaikka hyppäis yli. Nyt jää juntturaan pyörii.

Kiitti

Äänestä

Tämmöinen24.2.2018 klo 16.03
Onko siellä kenties erikoismerkkejä? Ainakaan [ ] * / \ ? : Eivät kelpaa. Silloin versionumeron lisääminen ei ratkaise ongelmaa, ja tyhmä virherutiini jää luuppiin. Nuo merkit pitää poistaa tai korvata toisilla. Lisäsin funktion, jolla luetellut merkit voi muuttaa mieleisiksi.

Toinen muutos on sen takia, että muun virheen kuin 1004 jälkeen Excel jäi avuttomaan tilaan, koska alussa blokatut toiminnot jäivät palauttamatta. Nyt ne palautetaan.

Function Siivoa(Orig As String, pois As String, tilalle As String) As String
    Dim i As Integer
    For i = 1 To Len(pois)
        Orig = Replace(Orig, Mid(pois, i, 1), Mid(tilalle, i, 1))
    Next i
    Siivoa = Orig
End Function

Sub Työkirjat_yhteen()

    Dim tämä, wb As Workbook
    Dim ws As Worksheet
    Dim Löytö, Nimiehdotus, nn, e As String
    Dim kopioitava As Range
    Dim i, r, n As Integer
    Dim alue As Variant
    alue = Array("B23:I26", "B29:I34", "B37:I42", "B45:I48", "B51:I54", "B57:I60", _
                 "B63:I66", "B69:I72", "B75:I80", "B83:I86", "B89:I92", "B95:I100")
    Const polku = "C:/temp/temp/"
    Const Haettavat = polku & "*.xlsx"

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set tämä = ActiveWorkbook
    Löytö = Dir(Haettavat) ' Ensimmäinen
    Do Until Löytö = ""

        Set wb = Workbooks.Open(polku & Löytö)
        Set ws = wb.Worksheets(1)
        DoEvents
        n = 0
        Nimiehdotus = Siivoa(ws.Range("C20"), "[]*/\?:", "()×....")
        nn = Nimiehdotus

On Error GoTo err:
Yritys:
        tämä.Sheets(1).Name = nn

        r = 5
        For i = 0 To UBound(alue)
            ws.Activate
            Range(alue(i)).Select
            Selection.Copy
            tämä.Activate
            Cells(r, 2).Select
            ActiveSheet.Paste

            r = Cells(Rows.Count, "B").End(xlUp).Row 1
        Next i

        wb.Close
        Löytö = Dir ' Seuraava
        If Löytö <> "" Then tämä.Sheets.Add
    Loop

Loppu:
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
Exit Sub

err:
    If err.Number = 1004 Then
        n = n 1
        nn = Nimiehdotus & "(" & n & ")"
        MsgBox (ws.Name & ": C20 = " & Nimiehdotus)
        Resume Yritys
    Else
        MsgBox (err.Number & " " & err.Description)
        GoTo Loppu:
    End If
End Sub
Äänestä

laakavaaka25.2.2018 klo 22.56

Moikka taasen

Välilehdelle tehty taulukko haettavia tietoja varten ja laitettu nappi, joka hakee ne toisilta työkirjoilta, siis työkirja per välilehti. Kun haussa on yksi työkirja, niin kaikki pelaa hyvin. Sivun asetukset toimii, sarakeleveydet, fontit yms. pysyy.

Mutta jos hakuun laittaa useamman työkirjan kerralla, niin alkaa tökkii. Välilehdelle tulee haetut tiedot oikeisiin soluihin, mutta taulukko puuttuu, joten sarakeleveydet eivät ole enää haluttuja.

Mul olis Malli -välilehdellä ko. sivuille tehty taulukko. Oisko tos ajatusta, että uusi välilehti luotas, tosta Malli -välilehdestä ja hakis tiedot sille. Näin pysys sivun asetukset kohillaan. Laittsitko vielä ton kondikseen. Kiitti

Äänestä

Tämmöinen26.2.2018 klo 3.33
Sarakeleveydet kopioituvat vain kopioitaessa kokonaisia sarakkeita.
Seuraava makro kopioi aktiivisen sivun muotoilun saman tiedoston kaikille sivuille.

Sub KopioiMuotoilut()
    Dim sivu As Worksheet
    Cells.Copy
    For Each sivu In Worksheets
         sivu.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone
    Next sivu
    Application.CutCopyMode = False
End Sub
Äänestä

Kundepuu26.2.2018 klo 7.31

Referenssit++Microsoft+Ado+ja++VBscripting+pitää+lisätäKokeilin+50++tiedostolla+ja+solussa+C20+osassa+samoja+nimiä+ja+muutaman+sekunnin+kesti+ajaa+läpi.Malli+taukossa+pitää+olla+muotoilutOption+ExplicitFunction+OnkoTaulukkoOlemassa(TaulukonNimi+As+String)+As+BooleanDim+sht+As+WorksheetOn+Error+Resume+NextSet+sht+=+Worksheets(TaulukonNimi)On+Error+GoTo+0OnkoTaulukkoOlemassa+=+Not+sht+Is+NothingEnd+FunctionFunction+Putsaa(Nimi+As+String)+As+StringDim+objRegExpDim+SiivottuSet+objRegExp+=+New+RegexpobjRegExp.IgnoreCase+=+TrueobjRegExp.Global+=+TrueobjRegExp.Pattern+=+"[(?*"",\\<>&#~%{}+_.@:\/!;]+"Siivottu+=+objRegExp.Replace(Nimi,+"_")Putsaa+=+SiivottuEnd+FunctionSub+PoistaVanhat()Dim+Ws+As+WorksheetOn+Error+Resume+NextApplication.DisplayAlerts+=+FalseFor+Each+Ws+In+WorksheetsIf+Not+Ws.Name+=+"Malli"+Then+Ws.DeleteNextApplication.DisplayAlerts+=+FalseEnd+SubSub+HaeSuljetuista()Dim+Polku+As+StringDim+Tiedostot+As+StringDim+sh+As+WorksheetDim+Löydetyt()+As+StringDim+Fnum+As+LongDim+rsCon+As+ObjectDim+rsData+As+ObjectDim+KundeConnect+As+StringDim+KundeSQL+As+StringDim+Lähdetiedosto+As+VariantDim+Lähdealue+As+StringDim+Kohdealue+As+RangeDim+Alue+As+VariantDim+i+As+LongDim+Solu+As+RangeDim+Siirtymä+As+LongDim+TaulukonNimi+As+StringDim+Ws+As+WorksheetDim+PutsattuNimi+As+String'+++Muuta+sopivaksiAlue+=+Array("C20:I126",+"B23:I26",+"B29:I34",+"B37:I42",+"B45:I48",+"B51:I54",+"B57:I60",+"B63:I66",+"B69:I72",+"B75:I80",+"B83:I86",+"B89:I92",+"B95:I100")'+++Muuta+sopivaksiPolku+=+"C:/testi/"'+++Muuta+sopivaksiTiedostot+=+Dir(Polku+&+"*.xl*")If+Tiedostot+=+""+Then++++MsgBox+"Ei+löytynyt+tiedostoja"++++Exit+SubEnd+IfOn+Error+GoTo+LoppuApplication.ScreenUpdating+=+False'Lisätään+löydetyt+tiedostot+arrayhinFnum+=+0Do+While+Tiedostot+<>+""++++Fnum+=+Fnum+++1++++ReDim+Preserve+Löydetyt(1+To+Fnum)++++Löydetyt(Fnum)+=+Tiedostot++++Tiedostot+=+Dir()Loop'Loopataan+tiedostot+läpi+ja+tallennetaan+tiedotIf+Fnum+>+0+Then++++++++Set+rsCon+=+CreateObject("ADODB.Connection")++++Set+rsData+=+CreateObject("ADODB.Recordset")++++For+Fnum+=+LBound(Löydetyt)+To+UBound(Löydetyt)++++++++Siirtymä+=+0++++++++KundeConnect+=+"Provider=Microsoft.Jet.OLEDB.4.0;"+&+"Data+Source="+&+Polku+&+Löydetyt(Fnum)+&+";"+&+"Extended+Properties=""Excel+8.0;HDR=No"";"++++++++rsCon.Open+KundeConnect++++++++For+i+=+0+To+UBound(Alue)++++++++++++KundeSQL+=+"SELECT+*+FROM+"+&+Alue(i)+&+";"++++++++++++rsData.Open+KundeSQL,+rsCon,+0,+1,+1++++++++++++If+Not+rsData.EOF+Then++++++++++++++++If+i+=+0+Then++++++++++++++++++++Worksheets("Malli").Range("A66536").CopyFromRecordset+rsData++++++++++++++++++++PutsattuNimi+=+Putsaa(Worksheets(1).Range("A66536"))++++++++++++++++++++If+Not+OnkoTaulukkoOlemassa(Worksheets(1).Range("A66536"))+Then++++++++++++++++++++++++Worksheets("Malli").Copy+After:=Worksheets("Malli")++++++++++++++++++++++++Worksheets(Worksheets("Malli").Index+++1).Name+=+Worksheets("Malli").Range("A66536")++++++++++++++++++++++++DoEvents+++++++++++++++++++++Else++++++++++++++++++++++++Worksheets("Malli").Copy+After:=Worksheets("Malli")++++++++++++++++++++++++++++++++++++++++++++++++Worksheets(Worksheets("Malli").Index+++1).Name+=+Worksheets("Malli").Range("A66536")+&+Worksheets.Count++++++++++++++++++++++++++++++++++++++++++++End+If++++++++++++++++Else++++++++++++++++++++If+i+=+1+Then+++++++++++++++++++++++++Worksheets(Worksheets("Malli").Index+++1).Range("B5").CopyFromRecordset+rsData++++++++++++++++++++Else+++++++++++++++++++++++++Worksheets(Worksheets("Malli").Index+++1).Range("B5").Offset(Siirtymä,+0).CopyFromRecordset+rsData++++++++++++++++++++End+If++++++++++++++++++++Siirtymä+=+Siirtymä+++Range(Alue(i)).Rows.Count++++++++++++++++++++++++++++++++++++End+If++++++++++++End+If++++++++++++rsData.Close+++++++++++++++++++Next+++++++rsCon.Close+++++++++++++++++NextEnd+IfSet+rsData+=+NothingSet+rsCon+=+NothingLoppu:On+Error+GoTo+0Application.ScreenUpdating+=+TrueEnd+SubKeep+EXCELIng@Kunde

Äänestä

Kundepuu26.2.2018 klo 8.01

jos tiedostot on .xlsx päätteisiä, niin vaiha koodiin. Tää toimii myös vanhemmilla .xls päätteillä...
KundeConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Polku & Löydetyt(Fnum) & ";" & "Extended Properties=""Excel 12.0;HDR=NO"";"

Äänestä

laakavaaka27.2.2018 klo 2.53

Moikka

No niin yritetääs saaha muutama rivi asiasta, josta ei oikein kässää mitään.

Työkirja, siinä oli ne kaks välilehtee, joissa molemmissa samanlaiset taulukot.
Taul1, sisältää sen painonapin ja Malli sitä kopsausta varten.
Käyttääkö Kunden versio vain Malli -välilehtee. Se on ainut nimi joka siellä vilahtaa.

Onkohan nää oikeet referenssit
Microsoft ADO Ext. 2.8 for DDL and Security
Microsoft VBScript Regular Expressions 5.5
Microsoft Scripting Runtime

Kaikki tiedostot se löys, mutta sit se jymähtää riville (menee tausta keltaseks)
Worksheets("Malli").Range("A66536").CopyFromRecordset rsData

ja antaa ilmotuksen
Run-time error '-2147467259 (80004005)':
Method 'CopyFromRecordset' of object 'Range' failed

No miltäs toi vaikuttaa. Loksahtaako sormia napauttamalla kohalleen

Äänestä

Kundepuu27.2.2018 klo 7.14

Microsoft ADO Ext. 2.8 for DDL and Security vaikuttaa aika vanhalta...
Mulla EXCEL 2013 ja Microsoft ADO Ext. 6.0 for DDL and Security

tuolta voit kopioida ton mun käytössä olevan
https://www.dropbox.com/s/70bdqgb4t5ffzhb/msadox.rar?dl=0

olikos sulla tää käytössä?
Tää toimii uusilla ja vanhoilla tiedostopäätteillä.
KundeConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Polku & Löydetyt(Fnum) & ";" & "Extended Properties=""Excel 12.0;HDR=NO"";"

Luultavasti toi sun vanha ADO ei toimi tolla vaan vaatii tämän
KundeConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & Polku & Löydetyt(Fnum) & ";" & "Extended Properties=""Excel 8.0;HDR=No"";"

vai toimisiko tällä?
KundeConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Polku & Löydetyt(Fnum) & ";" & "Extended Properties=""Excel 8.0;HDR=NO"";"

ja tiedostopäätteet pitää olla sitten .xls...
Jos sulla on päätteenä .xlsx, nii kokeile tallentaa se vanhempaa muotoon ja aja makro sitten, mutta helpointa lisätä toi linkin ADO ;-)

Keep EXCELing
@Kunde

Äänestä

laakavaaka28.2.2018 klo 1.54

Tsekkasin noi maholliset erilaisuudet ja toi ADOkin oli siellä pitkässä listassa. Tullu valittuu nähtävästi väärä versio siitä. Samoin noi koodirivit, niistäkin oli toi uudempi käytössä ja kotimaisella Office 365:llä mennään ja päätteenä on .xlsx, mutta kokeilin kyllä .xls päätteelläkin.

Mut tosta koodista. Siihen samaan riviin se tööttää, eikä mulla oo hajuukaan mitä pitäs tehä tai koittaa. Uuttahan tää mulle on ja tällästä koodii tainnu ennen nähäkkää, on ollu vaan niitä perinteisempii.

Mietiskelin kun tässä toi tiedoston luku tökkii, niin onkohan mulla niis aiemmin tallennetuissa tiedostoissa jotain sellasta, mistä toi koodi ei tykkää. Tulee ajatus kun aiemmin laitoit viestiin, et testasit 50:llä tiedostolla ja hyvin meni. Et laittasitko dropboxiin sen testipaketin kopsattavaks. No jospa se olis vaan tosta rivistä kiinni, toivotaan niin.

Äänestä

Kundepuu28.2.2018 klo 5.48

Tuossa originaali
https://www.dropbox.com/s/dt3unzlancyol3t/HakuSuljetusta.xlsm?dl=0

Äänestä

Kundepuu28.2.2018 klo 5.54

ja tossa 10 kpl tiedostoja

https://www.dropbox.com/s/9ahpaeizifyst9h/Hakusuljetusta.rar?dl=0

Äänestä

Kundepuu28.2.2018 klo 6.18

Hieman tsekkasin , eroaako 365 versio jotenkin v2010 ja silmääni pistikin heti bugi...
excel 365 database only returns 65K rows... ;-)
eli tossapa se syy sitten taitaakin olla, vaikka pitäisi palauttaa sen rapiat miljoona riviä.
eli koodissa pitää fiksata juurikin stoppirivin solun arvoa. Muuttaa se joksikin sopivaksi vaikka A1 ( koodi käyttää sitä väliaikaisesti ja se arvo poistetaan)
eli muuta Worksheets("Malli").Range("A66536").CopyFromRecordset rsData ja muutamat alemmalla rivillä olevat soluarvot sopivaksi esim.
Worksheets("Malli").Range("A1).CopyFromRecordset rsData ...

Keep EXCELing
@Kunde

Äänestä

laakavaaka28.2.2018 klo 14.52

No nii, näin siin kävi. Lähettämäs ohjelma ja data toimii ilman muutoksia Ok.

Vaihdoin mun datan sun datan tilalle.
- Tökkäs samalle riville kuin ennenkin (.xlsx)
- Vaihdoin tiedostomuotoa ja .xls toimi
- Muita muutoksia en tehnyt

Sit seuraavaks vein sun datan (mun) ohjelmaan ja aina tökkäs sille samalle riville, teki mitä teki.
En löytäny koodista mitään eroavaisuutta, mutta siitä en päätä pantiks laita. No nyt mulla on kuitenkin toimiva juttu, ja jatkan sen virittämistä. Saanen varmaan palata asiaan, jos tulevat yöt koneella tuo mutkia matkaan.

Kiitti

Äänestä

laakavaaka1.3.2018 klo 0.45

Toi prosessi kääntää noi välilehet laskevaan järjestykseen. Jotenkin silmä tottunu hahmottaa nousevan listauksen helpommin. Saisko sellasen nousevan järjestyksen tekevän koodinpätkän. Jälleen kiittelen

Äänestä

laakavaaka1.3.2018 klo 1.02

Se problem ratkes. Kääntelin ekaks väärän for..nextin parametrei ennenkuin hönäsin

Äänestä

Kundepuu1.3.2018 klo 15.52

Lähetä mulle .bugi xlsx ja toimiva .xls tiedostot, niin tsekkaan
hmetso(at) hotmail.com

Äänestä

Odottaa vastausta

Näihin keskusteluihin ei ole vielä vastattu. Ole ensimmäinen.

Ilmoitukset

Kopiointi muista työkirjoista

Muut lukivat myös

Vastaukset 19

Odottaa vastausta

Luetuimmat keskustelut

Kommentoi aloitusta

Ilmoita asiaton sisältö

Ilmoitus lähetetty

Jaa keskustelu