Pasted to the last row

[Athopp]

Hi Folks,
The purpose of this code is to copy all values generated from a formula in column 'B' and paste those values in column 'D'. Next the code copies all the values generated from a formula in column 'C' to the next available row in column 'D'. In the end, I should see all values for column 'B' and 'C' in column 'D' with no blank rows.

The problem is: the code seems to create tones of blank rows in column D between the values generated from B and C.

Example of desired output below:

Column B	Column C	Column D
TextB1	TextC1	TextB1
TextB2	TextC2	TextB2
TextB3		TextB3
TextB4		TextB4
		TextC1
		TextC2

Code below (except of relevant pieces; no Dims)

ActiveSheet.Range("$A$1:$E$50").AutoFilter Field:=2, Criteria1:="<>"
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.LargeScroll ToRight:=1
ActiveWindow.SmallScroll ToRight:=1
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
ActiveWindow.SmallScroll ToRight:=-2
Call Application.Calculate
ActiveSheet.Range("$A$1:$E$50").AutoFilter Field:=2
LastRow = ActiveWorkbook.Worksheets("Rename_Folders").Cells(Rows.Count, 4).End(xlUp).Row
NextRowExport = LastRow + 1

ActiveWorkbook.Worksheets("Rename_Folders").Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

ActiveWorkbook.Worksheets("Rename_Folders").Range("D" & NextRowExport).PasteSpecial xlPasteValues
Call Application.Calculate
Columns("B:C").EntireColumn.Hidden = True
Range("D2").Activate

 

[ekrause]

ActiveSheet.Range("$A$1:$E$50").AutoFilter Field:=2, Criteria1:="<>"
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.LargeScroll ToRight:=1
ActiveWindow.SmallScroll ToRight:=1
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
ActiveWindow.SmallScroll ToRight:=-2
Call Application.Calculate
ActiveSheet.Range("$A$1:$E$50").AutoFilter Field:=2
LastRow = ActiveWorkbook.Worksheets("Rename_Folders").Cells(Rows.Count, 4).End(xlUp).Row
NextRowExport = LastRow + 1

ActiveWorkbook.Worksheets("Rename_Folders").Range("C2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

'Remove this line - ActiveWorkbook.Worksheets("Rename_Folders").Range("D" & NextRowExport).PasteSpecial xlPasteValues

'checks if D2 is blank, if so pastes values in D2
If IsEmpty(Range("d2")) Then
    Range("d2").PasteSpecial xlPasteValues
    Else
        If IsEmpty(Range("d2").Offset(1)) Then 'checks if D3 is blank, if so pastes new data in D3 (not checking for this causes an error)
            Range("d2").Offset(1).PasteSpecial xlPasteValues
        Else
            Range("d2").End(xlDown).Offset(1).PasteSpecial xlPasteValues 'goes to bottom of data set, moves down 1 row then pastes values
        End If
End If

Call Application.Calculate
Columns("B:C").EntireColumn.Hidden = True
Range("D2").Activate

 

[johnnyL]

Assuming Row 2 is the starting row of your data ... How about:

Sub Test()
'
    Range("B2:B50").SpecialCells(xlCellTypeBlanks).Delete                                                               ' Delete Blank cells in column B
    Range("D2").Resize(WorksheetFunction.CountA(Range("B2:B50")), 1) = _
            Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Value                                                 ' Copy cells from Column B to Column D
'
    Call Application.Calculate
'
    Range("C2:C50").SpecialCells(xlCellTypeBlanks).Delete                                                               ' Delete Blank cells in column C
    Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1).Resize(WorksheetFunction.CountA(Range("C2:C50")), 1) = _
            Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row).Value                                                 ' Copy cells from Column C to Column D
'
    Call Application.Calculate
'
    Columns("B:C").EntireColumn.Hidden = True
'
    Range("D2").Activate
End Sub