• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 403
  • Last Modified:

how to insert new column using vba macro

Hi,

I currently have data that results after my tab macro runs.

Within there, I want to insert a column in front of A1, and shift everything over 1.

If data exists in B2, then add in Column A2 "2014".
If data exists in B3, then add in Column A3 "2015".

How can I go about this using a vba macro in excel?

sample data attached.

code for tab macro below:

Sub Tab_Clients()
Dim lr As Long, MaxRow As Long
Dim ws As Worksheet
Dim WSPY As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim cCell As Range
Dim FirstAddress As String

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

vcol = 1
Set ws = Sheets("Filtered from Current Year")
Set WSPY = Sheets("Filtered from Prev Year")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:BG1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
    MaxRow = Sheets(myarr(i) & "").Range("A" & Sheets(myarr(i) & "").Rows.Count).End(xlUp).Row + 1
    
    '---> Get Data from Last Year
    With WSPY.UsedRange
        Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If Not cCell Is Nothing Then
            FirstAddress = cCell.Address
            Do
                cCell.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & MaxRow)
                MaxRow = MaxRow + 1
                Set cCell = .FindNext(cCell)
            Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
        End If
    End With
    
    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

CHARTCLIENT2
Next
ws.AutoFilterMode = False
ws.Activate

'---> Enable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

'MsgBox "Creation of Clients tab done.", vbExclamation
End Sub

Open in new window


Thanks!
0
jfrank85
Asked:
jfrank85
  • 2
  • 2
1 Solution
 
Rgonzo1971Commented:
Hi,

pls try

If Range("B2") <> "" Then Range("A2")  = 2014
If Range("B3") <> "" Then Range("A3")  = 2015

Regards
0
 
gowflowCommented:
Is this what you want ?

Sub Tab_Clients()
Dim lr As Long, MaxRow As Long
Dim ws As Worksheet
Dim WSPY As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim cCell As Range
Dim FirstAddress As String
Dim ThisYr As String, LastYr As String

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

vcol = 1
Set ws = Sheets("Filtered from Current Year")
ThisYr = Format(Year(Now), "@")

Set WSPY = Sheets("Filtered from Prev Year")
LastYr = Format(Year(Now) - 1, "@")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:BG1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
        Sheets(myarr(i) & "").Range("A1") = "Year"
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = ThisYr
    Else
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = ThisYr
    End If
    MaxRow = Sheets(myarr(i) & "").Range("A" & Sheets(myarr(i) & "").Rows.Count).End(xlUp).Row + 1
    
    '---> Get Data from Last Year
    With WSPY.UsedRange
        Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If Not cCell Is Nothing Then
            FirstAddress = cCell.Address
            Do
                cCell.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & MaxRow)
                Sheets(myarr(i) & "").Range("A" & MaxRow).Insert xlShiftToRight
                Sheets(myarr(i) & "").Range("A" & MaxRow) = LastYr
                MaxRow = MaxRow + 1
                Set cCell = .FindNext(cCell)
            Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
        End If
    End With
    
    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

    'CHARTCLIENT
Next
ws.AutoFilterMode = False
ws.Activate

'---> Enable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

MsgBox "Creation of Clients tab done.", vbExclamation
End Sub

Open in new window


It will Insert the Year in Col A and shift all the rest from Col B to End.
Pls try the attached file.

gowflow
Sales-TY-LY-V02.xlsm
0
 
jfrank85Author Commented:
perfect, thanks!
0
 
gowflowCommented:
Your welcome
gowflow
0
 
jfrank85Author Commented:
how can i swap the data? seems its adding "2015" and its data on A2, and "2014" and its data on A3. I'd like to have both lines swapped.


thanks
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now