Help adding to a VBA code that I didn't write

[delaney1102]

Hi all, I have a VBA code that I didn't write, and while I can usually work out how to manipulate it, I'm having issues with this one. I've copied the code below. What I would like is that for each new "Elast" that there is an additional column at the end that only has the letter "E". Pretty simple I'd think? But I'm having a day.... thanks all!

Private Sub Census()

'This will reformat horizontal censuses into a vertical format in a new sheet.

On Error GoTo ErrorHandler
Dim Elast As Range, Efirst As Range, ezip As Range, egender As Range, edate As Range, etier As Range
Dim dlast As Range, dfirst As Range, doffset As Integer, dgender As Range, ddate As Range
Set Elast = Application.InputBox("Please select the cells containing employee last names", Type:=8)
Set Efirst = Application.InputBox("Please highlight the column containing employee first names", Type:=8)
Set ezip = Application.InputBox("Please highlight the column containing employee zip codes", Type:=8)
Set egender = Application.InputBox("Please highlight the column containing employee genders", Type:=8)
Set edate = Application.InputBox("Please highlight the column containing employee DOBs", Type:=8)
Set etier = Application.InputBox("Please highlight the column containing medical tiers", Type:=8)
Set dlast = Application.InputBox("Please highlight the column containing dependent last names", Type:=8)
Set dfirst = Application.InputBox("Please highlight the column containing dependent first names", Type:=8)
Set dgender = Application.InputBox("Please highlight the column containing dependent genders", Type:=8)
Set ddate = Application.InputBox("Please highlight the column containing dependent DOBs", Type:=8)
doffset = Application.InputBox("What is the distance between two dependents", Type:=1)
Dim efirstdistance As String, ezipdistance As String, egenderdistance As String, edatedistance As String, etierdistance As String
Dim dfirstdistance As String, dlastdistance As String, dgenderdistance As String, ddatedistance As String, doffsetdistance As String
efirstdistance = Efirst.Column - Elast.Column
ezipdistance = ezip.Column - Elast.Column
egenderdistance = egender.Column - Elast.Column
edatedistance = edate.Column - Elast.Column
etierdistance = etier.Column - Elast.Column
dlastdistance = dlast.Column - Elast.Column
dfirstdistance = dfirst.Column - Elast.Column
dgenderdistance = dgender.Column - Elast.Column
ddatedistance = ddate.Column - Elast.Column
Call CreateSheet
Dim cell As Range
Dim x As Integer: x = 1
Dim y As Integer
For Each cell In Elast
    cell.Copy
    Worksheets("New Sheet").Cells(x, 1).PasteSpecial
    cell.Offset(0, efirstdistance).Copy
    Worksheets("New Sheet").Cells(x, 2).PasteSpecial
    cell.Offset(0, ezipdistance).Copy
    Worksheets("New Sheet").Cells(x, 3).PasteSpecial
    cell.Offset(0, egenderdistance).Copy
    Worksheets("New Sheet").Cells(x, 4).PasteSpecial
    cell.Offset(0, edatedistance).Copy
    Worksheets("New Sheet").Cells(x, 5).PasteSpecial
    cell.Offset(0, etierdistance).Copy
    Worksheets("New Sheet").Cells(x, 6).PasteSpecial
    Worksheets("New Sheet").Cells(x, 7).PasteSpecial
    y = 0
    Do While (IsEmpty(cell.Offset(0, (dlastdistance + (doffset * y)))) = False) Or (IsEmpty(cell.Offset(0, (dlastdistance + (doffset * (y + 1))))) = False)
        If cell.Offset(0, dlastdistance + (doffset * y)) <> "" Then
            x = x + 1
            cell.Offset(0, dlastdistance + (doffset * y)).Copy
            Worksheets("New Sheet").Cells(x, 1).PasteSpecial
            cell.Offset(0, dfirstdistance + (doffset * y)).Copy
            Worksheets("New Sheet").Cells(x, 2).PasteSpecial
            cell.Offset(0, ezipdistance).Copy
            Worksheets("New Sheet").Cells(x, 3).PasteSpecial
            cell.Offset(0, dgenderdistance + (doffset * y)).Copy
            Worksheets("New Sheet").Cells(x, 4).PasteSpecial
            cell.Offset(0, ddatedistance + (doffset * y)).Copy
            Worksheets("New Sheet").Cells(x, 5).PasteSpecial
            cell.Offset(0, etierdistance).Copy
            Worksheets("New Sheet").Cells(x, 6).PasteSpecial
            Worksheets("New Sheet").Cells(x, 7).PasteSpecial
            y = y + 1
        Else:
            y = y + 1
        End If
    Loop
    x = x + 1
Next

ErrorHandler:
    If Err = 424 Then
        Exit Sub
    End If

End Sub

 

[Rich S]

Hard for me to follow, but I think you need 1 line somewhere, like

Worksheets("New Sheet").Cells(x, 7).PasteSpecial
Worksheets("New Sheet").Cells(x, 8) = "E"              '*<- Add this

Not sure though, why the author used all those ".Copy" and ".PasteSpecial" operations.
Why not do a simple value assignments, like

Worksheets("New Sheet").Cells(x, 2).Value = cell.Offset(0, efirstdistance).Value