VBA: transfer data from one sheet to another

Hello experts,

I use the following script to transfer data from active sheet to another sheet (CostCodeimport sheet)

Sub move_columns_CostCode_import()


' Description: Rearrange columns in Excel based on column header
Dim iRow As Long
Dim iCol As Long
Dim c As Range
Application.DisplayAlerts = False
On Error Resume Next
Sheets("CostCode_import").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Constant values
data_sheet1 = ActiveSheet.Name
target_sheet = "CostCode_import" 'Specify the sheet to store the results
iRow = Sheets(data_sheet1).UsedRange.Rows.Count 'Determine how many rows are in use
'Create a new sheet to store the results
Worksheets.Add.Name = "CostCode_import"
Application.DisplayAlerts = False
On Error Resume Next

Application.DisplayAlerts = False

'Delete unecessary rows

With Sheets(data_sheet1)

If Sheets(data_sheet1).Range("A1").Value = "" Then Sheets(data_sheet1).Rows("1:5").Delete .Columns("A:A").Delete

End With

Application.DisplayAlerts = True
'Start organizing columns
For iCol = 1 To Sheets(data_sheet1).UsedRange.Columns.Count
'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
TargetCol = 0
'Read the header of the original sheet to determine the column order

If Sheets(data_sheet1).Cells(1, iCol).Value = "Access CostCode" Then TargetCol = 1
If Sheets(data_sheet1).Cells(1, iCol).Value = "Project ID" Then TargetCol = 2
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 3
If Sheets(data_sheet1).Cells(1, iCol).Value = "Global ID" Then TargetCol = 4
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
If Sheets(data_sheet1).Cells(1, iCol).Value = "Global ID" Then TargetCol = 6
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Name" Then TargetCol = 7
If Sheets(data_sheet1).Cells(1, iCol).Value = "Accounting System" Then TargetCol = 8

'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot
If TargetCol <> 0 Then
'Select the column and copy it
Sheets(data_sheet1).Range(Sheets(data_sheet1).Cells(1, iCol), Sheets(data_sheet1).Cells(iRow, iCol)).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
End If
Next iCol 'Move to the next column until all columns are read

'Clean up

ActiveSheet.UsedRange.ClearFormats

End Sub

Open in new window



I don't know why the code doesn't work properly when I repeat a Targetcolumn name in different columns ex :

If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 3
If Sheets(data_sheet1).Cells(1, iCol).Value = "Global ID" Then TargetCol = 4
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
If Sheets(data_sheet1).Cells(1, iCol).Value = "Global ID" Then TargetCol = 6


I have  column 3 and 4 empty and column 5 and 6 with the right data and I should have colum 3, column 4 with the same data with column 5 and 6 respectively.

Thank you again for your help.
LVL 1
LD16Asked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Roy CoxGroup Finance ManagerCommented:
There's a few issues.

1. Don't put error handlers in until the code is working, if you do you will not receive error messages that may be helpful.
2. Look at Option Explicit and declaring variables.
3. You with  End With Statement is unnecessary and not used correctly.
4. Don't use UsedRange, it may return an incorrect range.

Attach an example workbook so that I can understand your code more easily.
Roy CoxGroup Finance ManagerCommented:
I've tidied up the code but I'm not sure what you are checking for with the Loop, as I said if you attach an example workbook I can probably figure it out.


Sub move_columns_CostCode_import()


' Description: Rearrange columns in Excel based on column header
    Dim iRow As Long
    Dim iCol As Long
    Dim c As Range
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("CostCode_import").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Constant values
    data_sheet1 = ActiveSheet.Name
    target_sheet = "CostCode_import"    'Specify the sheet to store the results

    'Create a new sheet to store the results
    Worksheets.Add.Name = "CostCode_import"
    Application.DisplayAlerts = False
    'On Error Resume Next

    Application.DisplayAlerts = False

    'Delete unecessary rows

    With Sheets(data_sheet1)

        If .Range("A1").Value = "" Then .Rows("1:5").Delete .Columns("A:A").Delete

        iRow = .Range("A1").Rows.Count    'Determine how many rows are in use

        Application.DisplayAlerts = True
        'Start organizing columns
        For iCol = 1 To .UsedRange.Columns.Count
            'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
            TargetCol = 0
            'Read the header of the original sheet to determine the column order

            If .Cells(1, iCol).Value = "Access CostCode" Then TargetCol = 1
            If .Cells(1, iCol).Value = "Project ID" Then TargetCol = 2
            If .Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 3
            If .Cells(1, iCol).Value = "Global ID" Then TargetCol = 4
            If .Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
            If .Cells(1, iCol).Value = "Global ID" Then TargetCol = 6
            If .Cells(1, iCol).Value = "Cost code Name" Then TargetCol = 7
            If .Cells(1, iCol).Value = "Accounting System" Then TargetCol = 8

            'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot
            If TargetCol <> 0 Then
                'Select the column and copy it
                .Range(.Cells(1, iCol), .Cells(iRow, iCol)).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
            End If
        Next iCol    'Move to the next column until all columns are read

        'Clean up

        ActiveSheet.UsedRange.ClearFormats

    End Sub

Open in new window

LD16Author Commented:
Please find attached the reference file.
Move-columns.xlsm
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
If empty columns is your issue, try this.....

Remember I have not changed any other lines of code, just added a variable col and used in the destination reference in the copy and paste line of code.

Sub move_columns_CostCode_import()

' Description: Rearrange columns in Excel based on column header
Dim iRow As Long
Dim iCol As Long
Dim c As Range
Dim col As Long
Application.DisplayAlerts = False
On Error Resume Next
Sheets("CostCode_import").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Constant values
data_sheet1 = ActiveSheet.Name
target_sheet = "CostCode_import" 'Specify the sheet to store the results
iRow = Sheets(data_sheet1).UsedRange.Rows.Count 'Determine how many rows are in use
'Create a new sheet to store the results
Worksheets.Add.Name = "CostCode_import"
Application.DisplayAlerts = False
On Error Resume Next

Application.DisplayAlerts = False

'Delete unecessary rows

With Sheets(data_sheet1)

If Sheets(data_sheet1).Range("A1").Value = "" Then Sheets(data_sheet1).Rows("1:5").Delete .Columns("A:A").Delete

End With

Application.DisplayAlerts = True
'Start organizing columns
col = 1
For iCol = 1 To Sheets(data_sheet1).UsedRange.Columns.Count
'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
TargetCol = 0
'Read the header of the original sheet to determine the column order

If Sheets(data_sheet1).Cells(1, iCol).Value = "Tccess CostCode" Then TargetCol = 1
If Sheets(data_sheet1).Cells(1, iCol).Value = "Project NTme" Then TargetCol = 2
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 3
If Sheets(data_sheet1).Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 4
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
If Sheets(data_sheet1).Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 6
If Sheets(data_sheet1).Cells(1, iCol).Value = "Cost code NTme" Then TargetCol = 7
If Sheets(data_sheet1).Cells(1, iCol).Value = "Tccounting System" Then TargetCol = 8

'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot

If TargetCol <> 0 Then
'Select the column and copy it
Sheets(data_sheet1).Range(Sheets(data_sheet1).Cells(1, iCol), Sheets(data_sheet1).Cells(iRow, iCol)).Copy Destination:=Sheets(target_sheet).Cells(1, col)
col = col + 1
End If
Next iCol 'Move to the next column until all columns are read

'Clean up

ActiveSheet.UsedRange.ClearFormats

End Sub

Open in new window


Does this help?
LD16Author Commented:
Thank you for your comment.

The idea is not to remove the empty data but transfer the information twice as it is specified in the if statetement.
Column 3 and 5 should have information related to Cost code Id
Column 4 and 6 should have informatoin related to GlobTl ID

At the end I should have 8 columns with values however if I launch your code I have  just 6 columns with values.

Thank you again for your help.
Roy CoxGroup Finance ManagerCommented:
I'm not sure if this is the correct results, I've made a few changes to the code
Move-columns.xlsm
Roy CoxGroup Finance ManagerCommented:
This is not good, if the wrong sheet is active then the code will not work correctly, which sheet should be active

data_sheet1 = ActiveSheet.Name

Open in new window


Maybe this will be better

Option Explicit
Sub move_columns_CostCode_import()


' Description: Rearrange columns in Excel based on column header
    Dim data_sheet1 As String, target_sheet As String
    Dim iRow As Long, iCol As Long, TargetCol As Long
    Dim c As Range
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("CostCode_import").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Constant values
    data_sheet1 = "Input"
    target_sheet = "CostCode_import"    'Specify the sheet to store the results
    iRow = Sheets(data_sheet1).UsedRange.Rows.Count    'Determine how many rows are in use
    'Create a new sheet to store the results
    Worksheets.Add.Name = "CostCode_import"
    On Error Resume Next

    Application.DisplayAlerts = False

    'Delete unecessary rows

    With Sheets(data_sheet1)

        If .Range("A1").Value = "" Then .Rows("1:5").Delete
        .Columns("A:A").Delete


    Application.DisplayAlerts = True
    'Start organizing columns
    For iCol = 1 To .Range("A1").CurrentRegion.Columns.Count
        'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
'        TargetCol = 0
        'Read the header of the original sheet to determine the column order

        If .Cells(1, iCol).Value = "Tccess CostCode" Then TargetCol = 1
        If .Cells(1, iCol).Value = "Project NTme" Then TargetCol = 2
        If .Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 3
        If .Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 4
        If .Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
        If .Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 6
        If .Cells(1, iCol).Value = "Cost code NTme" Then TargetCol = 7
        If .Cells(1, iCol).Value = "Tccounting System" Then TargetCol = 8

        'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot
        If TargetCol <> 0 Then
            'Select the column and copy it
            .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
        End If
    Next iCol    'Move to the next column until all columns are read

    End With
    'Clean up

    ActiveSheet.UsedRange.ClearFormats

End Sub

Open in new window

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I think you should show the desired output on CostCode_import Sheet so that we know that what output you are expecting exactly.

The problem with your current code is your TargetCol will always catch the first column header and hence will replace the old copied column in the destination sheet.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Since you haven't replied yet, give the following code a try to see if this is what you are trying to achieve.

Sub move_columns_CostCode_import()


' Description: Rearrange columns in Excel based on column header
    Dim data_sheet1 As String, target_sheet As String
    Dim iRow As Long, iCol As Long, TargetCol As Long, col As Long
    Dim c As Range
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("CostCode_import").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Constant values
    data_sheet1 = "Input"
    target_sheet = "CostCode_import"    'Specify the sheet to store the results
    iRow = Sheets(data_sheet1).UsedRange.Rows.Count    'Determine how many rows are in use
    'Create a new sheet to store the results
    Worksheets.Add.Name = "CostCode_import"
    On Error Resume Next

    Application.DisplayAlerts = False

    'Delete unecessary rows
    Sheets(data_sheet1).Activate
    With Sheets(data_sheet1)

        If .Range("A1").Value = "" Then
            .Rows("1:5").Delete
            .Columns("A:A").Delete
        End If

    Application.DisplayAlerts = True
    'Start organizing columns
    For iCol = 1 To .Range("A1").CurrentRegion.Columns.Count
        'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
'        TargetCol = 0
        'Read the header of the original sheet to determine the column order

        If .Cells(1, iCol).Value = "Tccess CostCode" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "Project NTme" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "Cost code Id" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "GlobTl ID" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "Cost code Id" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "GlobTl ID" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "Cost code NTme" Then
            TargetCol = iCol
        ElseIf .Cells(1, iCol).Value = "Tccounting System" Then
            TargetCol = iCol
        End If
        'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot
        If TargetCol <> 0 Then
            'Select the column and copy it
            .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, iCol)
        End If
    Next iCol    'Move to the next column until all columns are read

    End With
    'Clean up

    ActiveSheet.UsedRange.ClearFormats

End Sub

Open in new window

Roy CoxGroup Finance ManagerCommented:
Or maybe

Option Explicit
Sub move_columns_CostCode_import()


' Description: Rearrange columns in Excel based on column header
    Dim data_sheet1 As String, target_sheet As String
    Dim iRow As Long, iCol As Long, TargetCol As Long
    Dim iX As Integer
    '    Dim c As Range
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("CostCode_import").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Constant values
    data_sheet1 = "Input"
    target_sheet = "CostCode_import"    'Specify the sheet to store the results
    iRow = Sheets(data_sheet1).UsedRange.Rows.Count    'Determine how many rows are in use
    'Create a new sheet to store the results
    Worksheets.Add.Name = "CostCode_import"
    On Error Resume Next

    Application.DisplayAlerts = False

    'Delete unecessary rows

    With Sheets(data_sheet1)

        If .Range("A1").Value = "" Then .Rows("1:5").Delete
        .Columns("A:A").Delete


        Application.DisplayAlerts = True
        'Start organizing columns
        For iCol = 1 To .Range("A1").CurrentRegion.Columns.Count
            'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
            '        TargetCol = 0
            'Read the header of the original sheet to determine the column order

            If .Cells(1, iCol).Value = "Tccess CostCode" Then TargetCol = 1
            If .Cells(1, iCol).Value = "Project NTme" Then TargetCol = 2
            If .Cells(1, iCol).Value = "Cost code Id" Then
                For iX = 1 To 2
                    TargetCol = Choose(iX, 3, 5)
                    .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
                Next iX
            End If
            If .Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 4
            If .Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
            If .Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 6
            If .Cells(1, iCol).Value = "Cost code NTme" Then TargetCol = 7
            If .Cells(1, iCol).Value = "Tccounting System" Then TargetCol = 8

            'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot
            If TargetCol <> 0 Then
                'Select the column and copy it
                .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
            End If
        Next iCol    'Move to the next column until all columns are read

    End With
    'Clean up

    ActiveSheet.UsedRange.ClearFormats

End Sub

Open in new window


I don't think you use the Range variable c
LD16Author Commented:
@Roy_Cox this your last code works however I need to inegrate the

  For iX = 1 To 2
                    TargetCol = Choose(iX, 3, 5)
                    .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
                Next iX
            End If

For Field "GlobTl ID" as I need to have it in column 4 and 6 as it is done for "Cost code Id".

Thank you again for your help.
LD16Author Commented:
@sktneer with your code I am not able to get the columns data as specified in my file example.
LD16Author Commented:
Please find attached the result that I am looking for:
Move-columns-2.xlsm
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
What you have shown on CostCode_import sheet is your desired output?
LD16Author Commented:
Yes it is.
Roy CoxGroup Finance ManagerCommented:
Add another For  Loop

Option Explicit

Sub move_columns_CostCode_import()


' Description: Rearrange columns in Excel based on column header
    Dim data_sheet1 As String, target_sheet As String
    Dim iRow As Long, iCol As Long, TargetCol As Long
    Dim iX As Integer
    '    Dim c As Range
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("CostCode_import").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    'Constant values
    data_sheet1 = "Input"
    target_sheet = "CostCode_import"    'Specify the sheet to store the results
    iRow = Sheets(data_sheet1).UsedRange.Rows.Count    'Determine how many rows are in use
    'Create a new sheet to store the results
    Worksheets.Add.Name = "CostCode_import"
    On Error Resume Next

    Application.DisplayAlerts = False

    'Delete unecessary rows

    With Sheets(data_sheet1)

        If .Range("A1").Value = "" Then .Rows("1:5").Delete
        .Columns("A:A").Delete


        Application.DisplayAlerts = True
        'Start organizing columns
        For iCol = 1 To .Range("A1").CurrentRegion.Columns.Count
            'Sets the TargetCol to zero in order to prevent overwriting existing targetcolumns
            '        TargetCol = 0
            'Read the header of the original sheet to determine the column order

            If .Cells(1, iCol).Value = "Tccess CostCode" Then TargetCol = 1
            If .Cells(1, iCol).Value = "Project NTme" Then TargetCol = 2
            If .Cells(1, iCol).Value = "Cost code Id" Then
                For iX = 1 To 2
                    TargetCol = Choose(iX, 3, 5)
                    .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
                Next iX
            End If
             If .Cells(1, iCol).Value = "GlobTl ID" Then
                For iX = 1 To 2
                    TargetCol = Choose(iX, 4, 6)
                    .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
                Next iX
            End If
            If .Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 4
            If .Cells(1, iCol).Value = "Cost code Id" Then TargetCol = 5
            If .Cells(1, iCol).Value = "GlobTl ID" Then TargetCol = 6
            If .Cells(1, iCol).Value = "Cost code NTme" Then TargetCol = 7
            If .Cells(1, iCol).Value = "Tccounting System" Then TargetCol = 8

            'If a TargetColumn was determined (based upon the header information) then copy the column to the right spot
            If TargetCol <> 0 Then
                'Select the column and copy it
                .Range("a1").CurrentRegion.Columns(iCol).Copy Destination:=Sheets(target_sheet).Cells(1, TargetCol)
            End If
        Next iCol    'Move to the next column until all columns are read

    End With
    'Clean up

    ActiveSheet.UsedRange.ClearFormats

End Sub

Open in new window

LD16Author Commented:
Yes I thought the same however I don't get the result that I want look the Last Column of CostCode import which doesn't match with the one reported in the code.

Thank you for your help.
Move-columns-3.xlsm
Roy CoxGroup Finance ManagerCommented:
I'll have another look later. Does the new attachment have the desired results in?
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Okay try this to see if you get the desired output now.

I have followed completely different approach, see if this works for you.

Sub move_columns_CostCode_import()

' Description: Rearrange columns in Excel based on column header
Dim Sws As Worksheet, Dws As Worksheet
Dim iRow As Long
Dim col As Long, lc As Long

Application.DisplayAlerts = False

On Error Resume Next
Sheets("CostCode_import").Delete
On Error GoTo 0

Application.DisplayAlerts = True
'Constant values
Set Sws = Sheets("Input")
iRow = Sws.UsedRange.Rows.Count 'Determine how many rows are in use
'Create a new sheet to store the results
Worksheets.Add.Name = "CostCode_import"
Set Dws = Sheets("CostCode_Import")
Application.DisplayAlerts = False
On Error Resume Next

Application.DisplayAlerts = False
'Delete unecessary rows

With Sws
    If Sws.Range("A1").Value = "" Then Sws.Rows("1:5").Delete .Columns("A:A").Delete
End With

Application.DisplayAlerts = True
'Start organizing columns

If WorksheetFunction.CountIf(Sws.Rows(1), "Tccess CostCode") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("Tccess CostCode", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Project NTme") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("Project NTme", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Cost code Id") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("Cost code Id", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "GlobTl ID") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("GlobTl ID", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Cost code Id") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("Cost code Id", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "GlobTl ID") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("GlobTl ID", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Cost code NTme") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("Cost code NTme", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Tccounting System") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If
    col = WorksheetFunction.Match("Tccounting System", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If
    
'Clean up
Dws.UsedRange.ClearFormats
End Sub

Open in new window

Move-columns-v3.xlsm
LD16Author Commented:
@Roy_Cox: Nop it contains in CostCode_import the result after I launch your code.

Please find attached how I want the data in CostCode_import result sheet.
Move-columns-4.xlsm
LD16Author Commented:
@sktneer:Your code works, thank you again for your help.

I see in your code that you repeat multiple times the same statement

ex:
If WorksheetFunction.CountIf(Sws.Rows(1), "GlobTl ID") > 0 Then
    lc = Dws.Cells(1, Columns.Count).End(xlToLeft).Column
    If Dws.Range("A1") = "" Then
        lc = 1
    Else
        lc = lc + 1
    End If

Open in new window


Wouldn't be intersting to simplify the code and make another Generic sub in order to passing argument:

Something like that (an example of another question):

The generic sub in order to pass arguments

Sub DoIndexMatch(Target As Range, matchvalue As Range, comparedvalue As Range, DestinationColumn As String)
    Dim c As Range
    For Each c In matchvalue
        If IsNumeric(Application.Match(c, comparedvalue, 0)) Then
            Range(DestinationColumn & c.Row) = Application.WorksheetFunction.Index(Target, Application.WorksheetFunction.Match(c, comparedvalue, 0), 0)
        End If
    Next c
End Sub

Open in new window


Then  I call the Sub and i place my arguments ex:

Actions that to Run

Sub RunIndexMatch()
    DoIndexMatch Range("ccprojectstable!v2:v" & Rows.Count), Range("E2", Range("E" & Rows.Count).End(xlUp)), Range("ccprojectstable!A2:A" & Rows.Count), "B"
    DoIndexMatch Range("accountingtable!F2:F" & Rows.Count), Range("E2", Range("E" & Rows.Count).End(xlUp)), Range("accountingtable!A2:A" & Rows.Count), "O"
End Sub

Open in new window


Thank you very much for your help.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Yes you are correct, that could also be done with a function call.
Actually devoted too much of time to understand the logic and came with this while trying to tweak your own code so made the changes during runtime. :)

Glad something worked for you at last.
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Here is the revised code........

Sub move_columns_CostCode_import()

' Description: Rearrange columns in Excel based on column header
Dim Sws As Worksheet, Dws As Worksheet
Dim iRow As Long
Dim col As Long, lc As Long

Application.DisplayAlerts = False

On Error Resume Next
Sheets("CostCode_import").Delete
On Error GoTo 0

Application.DisplayAlerts = True
'Constant values
Set Sws = Sheets("Input")
iRow = Sws.UsedRange.Rows.Count 'Determine how many rows are in use
'Create a new sheet to store the results
Worksheets.Add.Name = "CostCode_import"
Set Dws = Sheets("CostCode_Import")
Application.DisplayAlerts = False
On Error Resume Next

Application.DisplayAlerts = False
'Delete unecessary rows

With Sws
    If Sws.Range("A1").Value = "" Then Sws.Rows("1:5").Delete .Columns("A:A").Delete
End With

Application.DisplayAlerts = True
'Start organizing columns

If WorksheetFunction.CountIf(Sws.Rows(1), "Tccess CostCode") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("Tccess CostCode", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Project NTme") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("Project NTme", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Cost code Id") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("Cost code Id", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "GlobTl ID") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("GlobTl ID", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Cost code Id") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("Cost code Id", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "GlobTl ID") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("GlobTl ID", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Cost code NTme") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("Cost code NTme", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If

If WorksheetFunction.CountIf(Sws.Rows(1), "Tccounting System") > 0 Then
    lc = GetColNum(Dws)
    col = WorksheetFunction.Match("Tccounting System", Sws.Rows(1), 0)
    Sws.Range(Sws.Cells(1, col), Sws.Cells(iRow, col)).Copy Dws.Cells(1, lc)
End If
    
'Clean up
Dws.UsedRange.ClearFormats
End Sub

Open in new window


Function GetColNum(ws As Worksheet) As Long
Dim LastCol As Long
LastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
If ws.Range("A1") = "" Then
    LastCol = 1
Else
    LastCol = LastCol + 1
End If
GetColNum = LastCol
End Function

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
LD16Author Commented:
It works, thank you again for your useful help!
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
You're welcome LD!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.