Kopiointi muista työkirjoista

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

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.

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

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

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

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 muotoilut


Option Explicit
Function OnkoTaulukkoOlemassa(TaulukonNimi As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = Worksheets(TaulukonNimi)
On Error GoTo 0
OnkoTaulukkoOlemassa = Not sht Is Nothing
End Function
Function Putsaa(Nimi As String) As String
Dim objRegExp
Dim Siivottu
Set objRegExp = New Regexp

objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "[(?*"",\\<>&#~%{} _.@:\/!;] "
Siivottu = objRegExp.Replace(Nimi, "_")
Putsaa = Siivottu
End Function
Sub PoistaVanhat()
Dim Ws As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
For Each Ws In Worksheets
If Not Ws.Name = "Malli" Then Ws.Delete
Next
Application.DisplayAlerts = False
End Sub

Sub HaeSuljetuista()
Dim Polku As String
Dim Tiedostot As String
Dim sh As Worksheet
Dim Löydetyt() As String
Dim Fnum As Long
Dim rsCon As Object
Dim rsData As Object
Dim KundeConnect As String
Dim KundeSQL As String
Dim Lähdetiedosto As Variant
Dim Lähdealue As String
Dim Kohdealue As Range
Dim Alue As Variant
Dim i As Long
Dim Solu As Range
Dim Siirtymä As Long
Dim TaulukonNimi As String
Dim Ws As Worksheet
Dim PutsattuNimi As String

' Muuta sopivaksi
Alue = 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 sopivaksi
Polku = "C:/testi/"
' Muuta sopivaksi
Tiedostot = Dir(Polku & "*.xl*")
If Tiedostot = "" Then
MsgBox "Ei löytynyt tiedostoja"
Exit Sub
End If

On Error GoTo Loppu
Application.ScreenUpdating = False


'Lisätään löydetyt tiedostot arrayhin
Fnum = 0
Do 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 tiedot
If 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

Next
End If
Set rsData = Nothing
Set rsCon = Nothing
Loppu:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Keep EXCELIng
@Kunde

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"";"

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

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

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.

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

ja tossa 10 kpl tiedostoja

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

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

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

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

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

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