Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Öffnen, kopieren, einfügen, Text in Spalte, speichern, Schließen

Betrifft: Öffnen, kopieren, einfügen, Text in Spalte, speichern, Schließen von: RO
Geschrieben am: 16.01.2020 14:12:34

Hallo zusammen,

könnte mir jemand bei der Code helfen?

Fuktioniert leider nicht so wie ich möchte. Ich versuche so:

1. Ersmal Zieldatei (Abfrage_Export_GE1) öffenen.
2. Dann die daten von Quelldatei zu kopieren.
3. Dann die Kopierte Datein in Zieldatei einfügen

4. Dann Text in Spalten in Zieldatei (Abfrage_Export_GE1)
5. Dann die Änderung von ZielDatei (Abfrage_Export_GE1) zu speichern
6. Und am Ende Zieldatei schlißen. (Abfrage_Export_GE1)

Schritt 4, 5 und 6 funktionieren leider nicht..

Kann jemand bitte sehen, wo der Fehler liegt?

Danke im Voraus ihr Helder.

Option Explicit

Sub GetAllUpdatesM()
Dim lLastRow As Long
Dim wkbOld As Workbook
Dim wkbNew As Workbook
Dim intCalculation As Integer
Dim Pfad As String
Dim Dateiname As String

Pfad = "R:\02_AUSWERTUNG_REPORTING\02_AUSWERTUNG\"

'Datei ?ffnen
Workbooks.Open Pfad & "Abfrage_Export_GE1.xlsm"

Const Abfrage_Export_DE As String = "R:\02_AUSWERTUNG_REPORTING\02_AUSWERTUNG\Abfrage_Export_DE.xlsx"
Const Abfrage_Export_EN As String = "R:\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_GE1")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastRow > 2 Then
.Range("A3:" & .UsedRange.SpecialCells(xlCellTypeLastCell).Address).ClearContents
End If
End With

Application.StatusBar = "check if worksheet in this file does exist"
If WorksheetExists("Abfrage_Export_GE1") Then
Sheets("Abfrage_Export_GE1").Activate
Else
Application.StatusBar = "create missing worksheet"
Sheets.Add
ActiveSheet.Name = " Abfrage_Export_GE1"
Sheets("Abfrage_Export_GE1").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_GE1").Range("A2").PasteSpecial xlPasteValues
wkbOld.Sheets("Abfrage_Export_GE1").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_GE1").Cells(wkbOld.Sheets("Abfrage_Export_GE1").Rows.Count, 1).End(xlUp).Row + 1
wkbOld.Sheets("Abfrage_Export_GE1").Range("A" & lLastRow).PasteSpecial xlPasteValues
wkbOld.Sheets("Abfrage_Export_GE1").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_GE1")
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

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 TextInSpalten(ws As Worksheet)
Dim mySpalten As Variant
Dim s As Variant

Dateiname = "Abfrage_Export_GE1.xlsm"

mySpalten = Array("I", "K", "L", "M", "N", "O", "Q", "S", "T", "U", "V", "W", "X", "Z", "AA", "AB", "AC", "AH", "AI", "AJ", "AM", "AP", "AQ", "AR", "AS") ' 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
Next

GetDataClosedWB = True

If GetDataClosedWB(Pfad, Dateiname) Then

MsgBox "Daten wurden erfolgreich kopiert!"

End If

End Sub

Betrifft: AW: Öffnen, kopieren, einfügen, Text in Spalte, speichern, Schließen
von: Hajo_Zi
Geschrieben am: 16.01.2020 16:50:16

Zu Deiner Datei kann ich nichts schreiben, was wohl daran liegt das ich nicht auf fremde Rechner schaue.Ich baue keine Datei nach.

Sollte die Datei verlinkt werden?

Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten
http://www.ms-office-forum.de/forum/showthread.php?t=322895
änderrn.

Das ist nur meGrußformelHomepage

ine Meinung zu dem Thema.

Beiträge aus dem Excel-Forum zum Thema "Öffnen, kopieren, einfügen, Text in Spalte, speichern, Schli"