Daten von einem Excel datei in die andere Excel Datei kopieren

Hallo zusammen,
ich finde hier immer gute Lösungen deswegen brauche ich wieder eure Hilfe.
1. Schritt: Aktuelle Werte in Blatt "Auswertung_EF" von Spalte A4 bis CJ der Exceldatei mit dem Name "Ausblick" löschen.
2. Shritt:
Ich habe eine Excel Datei die "Auswertung_Ge" heisst. Diese Datei ist xlsm. I dieser Datei befindet sich ein Blatt mit dem Name "Auswertung". Makro soll die Werte von A2 bis CJ kopieren.
3. Schritt:
Wenn er kopiert hat, dann muss er diese werte in Blatt "Auswertung_EF" von Spalte A4 bis CJ der Exceldatei mit dem Name "Ausblick". Die Werte müssen von Formel erkannt werden. (d.h. man muss nicht extra Text in spalte durchführen).
Das wäre sehr nett wenn jemand mir mit einer Code dabei helfen kann.
Danke schön im Voraus.
Robert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Copy_A4_CJ() Dim wkbQ As Workbook, wksQ As Worksheet Dim wkbZ As Workbook, wksZ As Worksheet Dim lngZeile As Long Set wkbQ = Application.Workbooks("Auswertung_Ge.xlsm") 'Name ggf. anpassen 'oder Set wkbQ = ThisWorkbook Set wksQ = wkbQ.Worksheets("Auswertung") Set wkbZ = Application.Workbooks("Auswertung_EF.xlsx") 'Name ggf. anpassen Set wksZ = wkbZ.Worksheets("Ausblick") 'Inhalte in "Ausblick" löschen With wksZ lngZeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 If lngZeile >= 4 Then .Range("A4:CJ" & lngZeile).ClearContents End If End With 'Inhalte in "Auswertung" kopieren With wksQ lngZeile = .UsedRange.Row + .UsedRange.Rows.Count - 1 If lngZeile >= 4 Then .Range("A4:CJ" & lngZeile).Copy Else MsgBox "es gibt nichts zu kopieren" Exit Sub End If End With 'Inhalte in "Ausblick" einfügen With wksZ .Range("A4").PasteSpecial Paste:=xlPasteValuesAndNumberFormats 'nur Werte und _ Zellformate 'oder .Range("A4").PasteSpecial Paste:=xlPasteAll 'alles End With Application.CutCopyMode = False End Sub

Hey vieleeeennnn Dank...hat ja super funktioniert...Bist ein Held!!!
Könntest du bitte schauen, warum bei diesem Code diese Pastevalue nicht funktioniert? Also ich muss immer Text in Spalte durchführen, um die Werte von den Formeln zu erkennen...
Könntest du eine Lösung mir sagen? Oder hätten Sie eine andere Code, der die gleiche Funktion und Aufgabe erfüllt? Wäre mega nett...
Option Explicit
Sub GetAllUpdates()
Dim lLastRow As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim intCalculation As Integer
Const Abfrage_Export_DE As String = "R:\8D_Evaluation\BMW_QMT_8D_MANAGEMENT_PROJECT\SERIE_8D_MANAGEMENT\01_BERICHTSWESEN\02_AUSWERTUNG_REPORTING\02_AUSWERTUNG\Abfrage_Export_DE.xlsx"
Const Abfrage_Export_EN As String = "R:\8D_Evaluation\BMW_QMT_8D_MANAGEMENT_PROJECT\SERIE_8D_MANAGEMENT\01_BERICHTSWESEN\02_AUSWERTUNG_REPORTING\02_AUSWERTUNG\Abfrage_Export_EN.xlsx"
Application.ScreenUpdating = False
Application.EnableEvents = False
intCalculation = Application.Calculation
Application.Calculation = xlManual
Set wkbOld = ActiveWorkbook
Application.StatusBar = "delete old data"
With wkbOld.Sheets("Abfrage_Export_GE")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 5 Then .Range("A2:AT" & lLastRow).ClearContents
End With
Application.StatusBar = "check if worksheet in this file does exist"
If WorksheetExists("Abfrage_Export_GE") Then
Sheets("Abfrage_Export_GE").Activate
Else
Application.StatusBar = "create missing worksheet"
Sheets.Add
ActiveSheet.Name = " Abfrage_Export_GE"
Sheets("Abfrage_Export_GE").Activate
End If
Application.StatusBar = "check if workbook " & Abfrage_Export_DE & " does exist, and open it"
If WkbExists(Abfrage_Export_DE) = False Then
If Dir(Abfrage_Export_DE) = "" Then
Else
Workbooks.Open Abfrage_Export_DE, UpdateLinks:=False
End If
Else
Workbooks(Abfrage_Export_DE).Activate
End If
Application.StatusBar = "check if worksheet in external file does exist"
Set wkbNew = ActiveWorkbook
If Not WorksheetExists("Abfrage_Export_DE") Then
Else
Application.StatusBar = "copy data"
wkbNew.Sheets("Abfrage_Export_DE").Activate
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wkbNew.ActiveSheet.Range("A2:AT" & lLastRow).Copy
Application.StatusBar = "paste data"
wkbOld.Sheets("Abfrage_Export_GE").Range("A2").PasteSpecial xlPasteValues
wkbOld.Sheets("Abfrage_Export_GE").Range("A2").PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.StatusBar = "close file"
wkbNew.Close False
Application.StatusBar = "check if workbook " & Abfrage_Export_EN & " does exist, and open it"
If WkbExists(Abfrage_Export_EN) = False Then
If Dir(Abfrage_Export_EN) = "" Then
Else
Workbooks.Open Abfrage_Export_EN, UpdateLinks:=False
End If
Else
Workbooks(Abfrage_Export_EN).Activate
End If
Application.StatusBar = "check if worksheet in external file does exist"
Set wkbNew = ActiveWorkbook
If Not WorksheetExists("Abfrage_Export_EN") Then
Else
Application.StatusBar = "copy data"
wkbNew.Sheets("Abfrage_Export_EN").Activate
lLastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
wkbNew.ActiveSheet.Range("A2:AT" & lLastRow).Copy
Application.StatusBar = "paste data"
lLastRow = wkbOld.Sheets("Abfrage_Export_GE").Cells(wkbOld.Sheets("Abfrage_Export_GE").Rows.Count, 1).End( _
xlUp).Row + 1
wkbOld.Sheets("Abfrage_Export_GE").Range("A" & lLastRow).PasteSpecial xlPasteValues
wkbOld.Sheets("Abfrage_Export_GE").Range("A" & lLastRow).PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End If
Application.StatusBar = "close file"
wkbNew.Close False
Application.StatusBar = "copy formulas"
With wkbOld.Sheets("Abfrage_Export_GE")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 2 Then
.Range("AW2:CJ2").Copy
.Range("AW3:CJ" & lLastRow).PasteSpecial
Application.CutCopyMode = False
End If
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub


Private Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function


Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
On Error Resume Next
WorksheetExists = (Sheets(WorksheetName).Name  "")
On Error GoTo 0
End Function

Sub LoopTextiSpalten() Dim WS_Count As Integer Dim Yexp As Integer ' Tabellenbl?tter auslesen in DB Export WS_Count = ActiveWorkbook.Worksheets.Count ' Begin the loop. For Yexp = 1 To WS_Count Sheets(Yexp).Select Call TextiSpalten Next Yexp End Sub

Sub TextiSpalten() Spmax = Cells(1, Columns.Count).End(xlToLeft).Column For i = 1 To Spmax Columns(i).Select Selection.TextToColumns Destination:=Cells(1, i), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1), TrailingMinusNumbers:=True Next i Danke dir man..

Sub TextInSpalten(ws As Worksheet) Dim mySpalten As Variant Dim s As Variant mySpalten = Array("I", "AH") ' ensprechend anpaasen For Each s In mySpalten ws.Columns(s).TextToColumns Destination:=ws.Range(s & "1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, _ FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True ws.Columns(s).NumberFormat = "0.00" Next End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Beliebteste Forumthreads (12 Monate)

Daten von einem Excel datei in die andere Excel Datei kopieren

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten von einem Excel datei in die andere Excel Datei kopieren

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread