Daten übertragen von Sepp

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Daten übertragen von Sepp
von: Andi
Geschrieben am: 01.07.2015 19:36:57

Hallo Sepp,
du hast mir vor längerer Zeit einen schönen VBA Code geschrieben, ich habe an der Quelltabelle etwas geändert und ein paar Zeilen angefügt, habe das auch in deinem Code angepasst, bekomme aber leider jetzt nur Zahlenwerte aus.
Wenn du mal kurz mal drüber schauen könntest währe SUPER!!
Vielen Dank im voraus
Andi
Die Datei
https://www.herber.de/bbs/user/98585.xlsm

Sub importData()
Dim objWB As Workbook, objOpen As Workbook
Dim lngRow As Long, lngCol As Long, lngI As Long, lngN As Long, lngLast As Long
Dim strFile As String
Dim bolOpen As Boolean
Dim lngCalc As Long
strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
                "*.xls; *.xlsx; *.xlsm", 1, "Datei zum Datenimport auswählen")
If strFile = "Falsch" Then Exit Sub
On Error GoTo ErrExit
With Application
  .ScreenUpdating = False
  .EnableEvents = False
  lngCalc = .Calculation
  .Calculation = -4135
  .DisplayAlerts = False
End With
With Me.Range("A8:H" & Me.Rows.Count)
  .Clear
  .Borders.LineStyle = xlNone
End With
lngN = 8
For Each objOpen In Application.Workbooks
  If objOpen.FullName = strFile Then
    Set objWB = objOpen
    bolOpen = True
    Exit For
  End If
Next
If objWB Is Nothing Then Set objWB = Workbooks.Open(strFile)
With objWB.Sheets("Tabelle1") 'Name der Datentabelle - Anpassen!
  lngLast = Application.Max(16, .Cells(.Rows.Count, 1).End(xlUp).Row)
  
  For lngRow = 16 To lngLast
    For lngCol = 16 To 70
      If .Cells(lngRow, lngCol) <> "" And .Cells(lngRow, lngCol) < 2 Then
        Me.Cells(lngN, 1) = .Cells(lngRow, 1).Value
        Me.Cells(lngN, 2) = .Cells(lngRow, 2).Value
        Me.Cells(lngN, 3) = .Cells(lngRow, 4).Value
        Me.Cells(lngN, 4) = .Cells(lngRow, 5).Value
        Me.Cells(lngN, 5) = .Cells(lngRow, 3).Value
        Me.Cells(lngN, 6) = .Cells(5, lngCol).Value
        lngN = lngN + 1
      End If
    Next
  Next
End With
If Not bolOpen Then objWB.Close False
If lngN > 8 Then
  MsgBox lngN - 1 & " Datensätze importiert!", vbInformation, "Import"
  With Me.Range("A8:F" & lngN - 1)
    .Borders(xlEdgeTop).LineStyle = xlContinuous
    .Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Borders(xlEdgeRight).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
  End With
Else
  MsgBox "Keine Daten gefunden!", vbInformation, "Import"
End If
ErrExit:
With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'importData'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
          .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
            "VBA - Fehler in Prozedur - importData"
    .Clear
  End If
End With
On Error GoTo 0
With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = lngCalc
  .DisplayAlerts = True
  .StatusBar = False
End With
Set objWB = Nothing
Set objOpen = Nothing
End Sub

Bild

Betrifft: AW: Daten übertragen von Sepp
von: Andi
Geschrieben am: 01.07.2015 21:19:10
Hallo Sepp,
Sorry habe es selber hinbekommen.
Hat sich erledigt!!
Trotzdem Danke nochmal
Andi

Bild

Betrifft: AW: Daten übertragen von Sepp
von: Sepp
Geschrieben am: 01.07.2015 22:22:13
Hallo Andi,
auf die schnelle fällt mir auf, das es statt

Me.Cells(lngN, 6) = .Cells(5, lngCol).Value

jetzt
Me.Cells(lngN, 6) = .Cells(15, lngCol).Value

heißen muss.
Gruß Sepp


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Daten übertragen von Sepp"