How do I insert data into the first empty cell in a selected column?

[t0mnas]

Hello Together ,

I have the following problem that the second data of the second column is inserted first under the data of the first (see picture). Any solution is welcome.

Option Explicit 

Sub DataTransfer()

Dim Dateiname As Variant
Dim wbPeriode As Workbook
Dim wsPeriode As Worksheet
Dim wbAufwandsliste As Workbook
Dim wsAufwandsliste As Worksheet
Dim lastRowPeriode As Long
Dim lastRowPeriode1 As Long
Dim lr As Long
Dim meineListe As ListRows
Dim meineListe1 As ListRows
Dim rngPeriode As Range
Dim objListObj As ListObject
Dim objListCols As ListColumns
Dim rngAufwandsliste As Range
Dim row As Range
Dim newRow As ListRow


'Application.ScreenUpdating = False
'Application.DisplayAlerts = False

Set wbAufwandsliste = ThisWorkbook
Set wsAufwandsliste = wbAufwandsliste.Worksheets(6).ListObject("Tabelle2")

Dateiname = Application.GetOpenFilename(FileFilter:="Excel-Dateien (*.xls*),*.xls*")



If Dateiname <> False Then
    

    Set wbPeriode = Workbooks.Open(Filename:=Dateiname)
    

    Set wsPeriode = wbPeriode.Worksheets(1)
    
    lastRowPeriode = wsPeriode.Cells(wsPeriode.Rows.Count, 1).End(xlUp).row
    lastRowAufwandsliste = wbAufwandsliste.Worksheets(6).ListObjects("Tabelle2").Range("B" & Rows.Count).End(xlUp).row
    
    
    Set meineListe = wbAufwandsliste.Worksheets(6).ListObjects("Tabelle2").ListRows
    Set rngPeriode = wsPeriode.Range("E2:E" & lastRowPeriode)
    
        For Each row In rngPeriode.Rows.SpecialCells(xlCellTypeVisible)
            Set newRow = meineListe.Add
            newRow.Range.Cells(1, 1) = row.Value
        Next row
    
    

    Set rngPeriode = wsPeriode.Range("F2:F" & lastRowPeriode)
    lr = wsAufwandsliste.Range("B" & Rows.Count).End(xlUp).row
    
        For Each row In rngPeriode.Rows.SpecialCells(xlCellTypeVisible)
            Set newRow = meineListe.Add
            newRow.Range.Cells(1, 2) = row.Value
        Next row
        
End If

wbPeriode.Close SaveChanges:=False
Application.ScreenUpdating = True

End Sub

 

[DanteAmor]

Hi @t0mnas. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

I hope you don't mind, but I made some tweaks to your code:

Sub DataTransfer()
  Dim wbPeriode As Workbook
  Dim wsAufwandsliste As Worksheet, wsPeriode As Worksheet
  Dim newRow As ListRow
  Dim Dateiname As Variant
  Dim rngPeriode As Range, row As Range
  
  Application.ScreenUpdating = False
  
  Set wsAufwandsliste = ThisWorkbook.Sheets(6)
  Dateiname = Application.GetOpenFilename(FileFilter:="Excel-Dateien (*.xls*),*.xls*")
  If Dateiname <> False Then
    Set wbPeriode = Workbooks.Open(Filename:=Dateiname)
    Set rngPeriode = wbPeriode.Sheets(1).Range("E2", wbPeriode.Sheets(1).Range("E" & Rows.Count).End(3))
    For Each row In rngPeriode.Rows.SpecialCells(xlCellTypeVisible)
      Set newRow = wsAufwandsliste.ListObjects("Tabelle2").ListRows.Add
      newRow.Range.Cells(1, 1).Resize(1, 2).Value = row.Resize(1, 2).Value
    Next row
  End If
  
  wbPeriode.Close SaveChanges:=False
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

 

[t0mnas]

Hi @t0mnas. Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

I hope you don't mind, but I made some tweaks to your code:

Sub DataTransfer()
  Dim wbPeriode As Workbook
  Dim wsAufwandsliste As Worksheet, wsPeriode As Worksheet
  Dim newRow As ListRow
  Dim Dateiname As Variant
  Dim rngPeriode As Range, row As Range
 
  Application.ScreenUpdating = False
 
  Set wsAufwandsliste = ThisWorkbook.Sheets(6)
  Dateiname = Application.GetOpenFilename(FileFilter:="Excel-Dateien (*.xls*),*.xls*")
  If Dateiname <> False Then
    Set wbPeriode = Workbooks.Open(Filename:=Dateiname)
    Set rngPeriode = wbPeriode.Sheets(1).Range("E2", wbPeriode.Sheets(1).Range("E" & Rows.Count).End(3))
    For Each row In rngPeriode.Rows.SpecialCells(xlCellTypeVisible)
      Set newRow = wsAufwandsliste.ListObjects("Tabelle2").ListRows.Add
      newRow.Range.Cells(1, 1).Resize(1, 2).Value = row.Resize(1, 2).Value
    Next row
  End If
 
  wbPeriode.Close SaveChanges:=False
  Application.ScreenUpdating = True
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------

thank you, it works, you have helped me incredibly