Avatar billede larskoch Nybegynder
06. oktober 2014 - 10:59 Der er 2 kommentarer og
1 løsning

Hjælp til makro til samling af data

Hej
Har følgende makro til brug for samling af data fra x antal ark til et Samlet ark. Der er i alt ca 26.000 linier der skal samles men koden stopper efter ca 19.000 pga ressourcemæssige problemer i excel ????
Kan ikke lige gennemskue hvor i koden jeg kan rette/opimere så den kam samle alle data - det er jo ikke så mange linier....

Sub Makro1()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim myWksCount As Integer
Dim LastRow As Long

On Error GoTo Error_Handler

If WorksheetExists("Samlet") = True Then
    Application.DisplayAlerts = False
    Set ws = ActiveWorkbook.Sheets("Samlet")
    ws.Delete
    Application.DisplayAlerts = True
End If

myWksCount = ActiveWorkbook.Worksheets.Count

ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "Samlet"

For i = 1 To myWksCount
    Sheets(i).Activate
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1").EntireColumn.Insert
    For j = 2 To LastRow
    Cells(j, 1).Value = i
    Next j
    Cells(2, 2).Select
    Selection.CurrentRegion.Select
    Selection.Copy
 
    Sheets("Samlet").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Cells(LastRow + 1, 1).Select
Next

For i = 1 To myWksCount
    Sheets(i).Activate
    Columns("A:A").Delete
Next

Error_Handler_Exit:
On Error Resume Next
Exit Sub

Error_Handler:
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Makro1" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Sub
Function WorksheetExists(wsName As String) As Boolean

Dim ws As Worksheet
Dim ret As Boolean

On Error GoTo Error_Handler

    ret = False
    wsName = UCase(wsName)
    For Each ws In ThisWorkbook.Sheets
        If UCase(ws.Name) = wsName Then
            ret = True
            Exit For
        End If
    Next
    WorksheetExists = ret
   
Error_Handler_Exit:
On Error Resume Next
Exit Function

Error_Handler:
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: WorksheetExists" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
Avatar billede kabbak Professor
06. oktober 2014 - 18:21 #1
Sub Makro1()
    Dim ws As Worksheet
    Dim i As Integer
    Dim Sidste As Long
    Dim myWksCount As Integer
    Dim LastRow As Long

    On Error GoTo Error_Handler

    If WorksheetExists("Samlet") = True Then
        Application.DisplayAlerts = False
        ActiveWorkbook.Sheets("Samlet").Delete
        Application.DisplayAlerts = True
    End If

    myWksCount = ActiveWorkbook.Worksheets.Count

    ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "Samlet"

    For i = 1 To myWksCount
          Sheets(i).Activate
        Data = Sheets(i).Range(Range("A2"), Range("A2").SpecialCells(xlLastCell))
        LastRow = Sheets("Samlet").Range("B" & Rows.Count).End(xlUp).Row + 1
        Sheets("Samlet").Activate
        Sheets("Samlet").Cells(LastRow, 2).Resize(UBound(Data, 1), UBound(Data, 2)) = Data
        Sidste = LastRow + UBound(Data, 1) - 1
      Sheets("Samlet").Range(Cells(LastRow, 1), Cells(Sidste, 1)) = i
    Next

Error_Handler_Exit:
    On Error Resume Next
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
          "Error Number: " & Err.Number & vbCrLf & _
          "Error Source: Makro1" & vbCrLf & _
          "Error Description: " & Err.Description, _
          vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub
Avatar billede kabbak Professor
06. oktober 2014 - 18:23 #2
måske skal jeg vise det hele ;-)

Sub Makro1()
    Dim ws As Worksheet
    Dim i As Integer
    Dim Sidste As Long
    Dim myWksCount As Integer
    Dim LastRow As Long
    Dim Data As Variant
    On Error GoTo Error_Handler

    If WorksheetExists("Samlet") = True Then
        Application.DisplayAlerts = False
        ActiveWorkbook.Sheets("Samlet").Delete
        Application.DisplayAlerts = True
    End If

    myWksCount = ActiveWorkbook.Worksheets.Count

    ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "Samlet"

    For i = 1 To myWksCount
        Sheets(i).Activate
        Data = Sheets(i).Range(Range("A2"), Range("A2").SpecialCells(xlLastCell))
        LastRow = Sheets("Samlet").Range("B" & Rows.Count).End(xlUp).Row + 1
        Sheets("Samlet").Activate
        Sheets("Samlet").Cells(LastRow, 2).Resize(UBound(Data, 1), UBound(Data, 2)) = Data
        Sidste = LastRow + UBound(Data, 1) - 1
        Sheets("Samlet").Range(Cells(LastRow, 1), Cells(Sidste, 1)) = i
    Next

Error_Handler_Exit:
    On Error Resume Next
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
          "Error Number: " & Err.Number & vbCrLf & _
          "Error Source: Makro1" & vbCrLf & _
          "Error Description: " & Err.Description, _
          vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub
Function WorksheetExists(wsName As String) As Boolean

    Dim ws As Worksheet
    Dim ret As Boolean

    On Error GoTo Error_Handler

    ret = False
    wsName = UCase(wsName)
    For Each ws In ThisWorkbook.Sheets
        If UCase(ws.Name) = wsName Then
            ret = True
            Exit For
        End If
    Next
    WorksheetExists = ret

Error_Handler_Exit:
    On Error Resume Next
    Exit Function

Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
          "Error Number: " & Err.Number & vbCrLf & _
          "Error Source: WorksheetExists" & vbCrLf & _
          "Error Description: " & Err.Description, _
          vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function
Avatar billede kabbak Professor
03. december 2014 - 12:59 #3
hvoran går det ??
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester