This might do it :-
Option Explicit
Sub StackColumns()
Dim nFixedColumn As Long, nMoveableColumn As Long
Do Until Not ColumnHeaderDuplicated(nFixedColumn, nMoveableColumn) ' returned ByRef
If nMoveableColumn > 0 Then
Range(Cells(2, nMoveableColumn), Cells(LastRowInColumn(nMoveableColumn), nMoveableColumn)).Cut _
Cells(LastRowInColumn(nFixedColumn) + 1, nFixedColumn)
Columns(nMoveableColumn).Delete
End If
Loop
End Sub
Function ColumnHeaderDuplicated(nFixedColumn As Long, nMoveableColumn As Long) As Boolean
Dim nColumn As Long, nErrorNumber As Long
Dim rCell As Range, clxColumnNames As New Collection, vCellValue As Variant
For Each rCell In Rows(1).SpecialCells(xlTextValues).Cells ' empty header ignored by design
vCellValue = Trim(rCell.Value) ' header with formulae ignored by design
If vCellValue > "" Then ' ignore header with only spaces
On Error Resume Next
clxColumnNames.Add rCell.Column, "key" & vCellValue
nErrorNumber = Err.Number
On Error GoTo 0
Select Case nErrorNumber
Case 0
Case 457
nFixedColumn = clxColumnNames.Item("key" & vCellValue)
nMoveableColumn = rCell.Column
ColumnHeaderDuplicated = True
Exit Function
Case Else
MsgBox "Bad cell content in " & rCell.Address '
''''
End Select
End If
Next rCell
ColumnHeaderDuplicated = False
End Function
Function LastRowInColumn(nColumn) As Long
LastRowInColumn = Cells(Rows.Count, nColumn).End(xlUp).Row
End Function
Derek Turner
England +++
From: "shocksrock@comcast.net [ExcelVBA]" <ExcelVBA@yahoogroups.com>
To: ExcelVBA@yahoogroups.com
Sent: Wednesday, 16 July 2014, 3:27
Subject: [ExcelVBA] Append columns into one column that have the same header
Hi,I have a worksheet that has multiple columns sharing the same header names. I need all of those to just have one column. It is critical that the first column found that has a matching header is appended below the first column with that header, the second column found that has a matching header is appended below the second column of information that was appended to the original, etc..I have a sample, but don't know how to attach it to this group. If somebody can give me a heads up on how to do that I'll attach my from/to example.Thanks in advance for any advice.Steve
__._,_.___
Posted by: Derek Turner <g4swy@yahoo.com>
| Reply via web post | • | Reply to sender | • | Reply to group | • | Start a New Topic | • | Messages in this topic (1) |
Yahoo Groups
Improved Group Homepage!
The About page of your Group now gives you a heads up display of recent activity, including the latest photos and files
Yahoo Groups
Control your view and sort preferences per Yahoo Group
You can now control your default Sort & View Preferences for Conversations, Photos and Files in the membership settings page.
----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
.
__,_._,___
Tidak ada komentar:
Posting Komentar