I want to change the names of the columns in an Excel sheet.
I want to rename the column headers as in the image.
You don't say if there is more than one area with these headers, so my solution will work for several. Unfortunately it will work for a maximum of 26 columns, one for each letter of the alphabet. You can expand it if you want.
I've included workbook and worksheet names, these are particular to me, you'll obviously have to change them.
The code looks for areas of data and steps through them, changing the headers on each one. You can adapt the code to just do one area of course. The code starts in the top left of the area, and steps across one cell at a time until it runs out of data, then it moves onto the next area.
Sub NewColumnNames()
Dim FruityColumnNames(26) As String
Dim a As Integer
Dim Alphabetical As Integer
FruityColumnNames(1) = "Apple"
FruityColumnNames(2) = "Banana"
FruityColumnNames(3) = "Cherry"
FruityColumnNames(4) = "Damson"
FruityColumnNames(5) = "Elderberry"
FruityColumnNames(6) = "Fig"
FruityColumnNames(7) = "Gooseberry"
FruityColumnNames(8) = "Hawthorn"
FruityColumnNames(9) = "Ita palm"
FruityColumnNames(10) = "Jujube"
FruityColumnNames(11) = "Kiwi"
FruityColumnNames(12) = "Lime"
FruityColumnNames(13) = "Mango"
FruityColumnNames(14) = "Nectarine"
FruityColumnNames(15) = "Orange"
FruityColumnNames(16) = "Passion fruit"
FruityColumnNames(17) = "Quince"
FruityColumnNames(18) = "Raspberry"
FruityColumnNames(19) = "Sloe"
FruityColumnNames(20) = "Tangerine"
FruityColumnNames(21) = "Ugli"
FruityColumnNames(22) = "Vanilla"
FruityColumnNames(23) = "Watermelon"
FruityColumnNames(24) = "Xigua"
FruityColumnNames(25) = "Yumberry"
FruityColumnNames(26) = "Zucchini"
With Workbooks("TestBook.xlsx")
With .Worksheets("Destination")
With .UsedRange.SpecialCells(xlCellTypeConstants)
For a = .Areas.Count To 1 Step -1
Alphabetical = 1
With .Areas(a)
While (.Cells(1, Alphabetical) <> "" And Alphabetical <= 26)
.Cells(1, Alphabetical).Value = FruityColumnNames(Alphabetical)
Alphabetical = Alphabetical + 1
Wend
End With
Next a
End With
End With
End With
End Sub
Example call (with reduced code):
Sub ChangeHeaderNames()
Dim headers: headers = Split("Apple,Banana,Cherry", ",")
Sheet1.Range("A1").Resize(1, UBound(headers) + 1) = headers ' << change to sheet's Code(Name)
End Sub
Related
I start using structured table with VBA code, but here I face a problem which I do not manage by myself.
I have a structured table in which I loop through 1 column and need to get values from other columns depending on some criteria:
if the cells value is "Finished"
then I take 3 dates (dateScheduled, dateRelease and dateReady) from 3 other columns and perform some calculations and tests based on these dates
the problem is that I can get the values of the date columns (they are well formatted and have values in it), so none of the next actions triggered by the first if is working.
Here is part of the whole code of my macro, I hope this is sufficient to figure out what is wrong.
For Each valCell In Range("thisIsMyTable[Task Status]").Cells
If valCell = "Finished" Then
dateScheduled = Range("thisIsMyTable[End Date]").Cells
dateRelease = Range("thisIsMyTable[Release Date]").Cells
dateReady = Range("thisIsMyTable[Date Ready]").Cells
totalFinishCat = totalFinishCat + 1
daysToFinished = daysToFinished + DateDiff("d", dateReady, dateRelease)
If Range("thisIsMyTable[Time Spent]").Cells = "" Then
timeTotalFinished = timeTotalFinished + Range("thisIsMyTable[Time estimate]").Cells + Range("thisIsMyTable[Extra hours]").Cells
Else
timeTotalFinished = timeTotalFinished + Range("thisIsMyTable[Time Spent]").Cells
End If
If dateRelease >= dateStartReport Then
monthFinished = monthFinished + 1
timeMonthFinished = timeMonthFinished + Range("thisIsMyTable[Time Spent]").Cells
daysToFinishedMonth = daysToFinishedMonth + DateDiff("d", dateReady, dateRelease)
If dateRelease > dateScheduled Then
afterDue = afterDue + 1
diff = DateDiff("d", dateScheduled, dateRelease)
afterDay = afterDay + diff
Else
beforeDue = beforeDue + 1
diff = DateDiff("d", dateRelease, dateScheduled)
beforeDay = beforeDay + diff
End If
End If
End If
Next valCell
I have tried out by adding .value or .value2 like so:
dateScheduled = Range("thisIsMyTable[End Date]").Cells.value
or
dateScheduled = Range("thisIsMyTable[End Date]").Cells.value2
but it does not work better. I have checked by adding .select like so:
dateScheduled = Range("thisIsMyTable[End Date]").Cells.select
and this will select the entire column, not the cells as I expect. So it appears that my method to just get the cells value is not appropriate.
Any help is welcome
If you create a lookup of column names to column number, you can loop through the rows of the table and extract the value using Range(1, columnno). For example
Option Explicit
Sub MyMacro()
Dim ws As Worksheet, tb As ListObject
Dim r As ListRow
Dim sStatus As String, dEnd As Date, dRelease As Date, dReady As Date
' table
Set ws = Sheet1
Set tb = ws.ListObjects("thisIsMyTable")
' lookup column name to number
Dim dict As Object, c As ListColumn
Set dict = CreateObject("Scripting.Dictionary")
For Each c In tb.ListColumns
dict.Add c.Name, c.Index
Next
' scan table rows
For Each r In tb.ListRows
sStatus = r.Range(1, dict("Task Status"))
If sStatus = "Finished" Then
dEnd = r.Range(1, dict("End Date"))
dRelease = r.Range(1, dict("Release Date"))
dReady = r.Range(1, dict("Date Ready"))
Debug.Print dEnd, dRelease, dReady
End If
Next
End Sub
I have been trying out something, by looking at other code ecample and stuff like that.
But I have some problems.
In my data input sheet, i have a dropdown menu with possible Names. But from what I have made now in the code, it just delete that. It does not copy the data over in other sheet and then just blank it out in data sheet, so every time I would have to make the dropdown list again.
Also when it move it over, it first move it to row 2, then to row 4. So jump over row 3, but then after that it just go to row 4 again and overwrite what is in row 4.
I think I need some kind of variables here for each sheet, but Im not strong in VBA, so not sure how to do it.
Here is the code that I have.
Sub CommandButton1_Click()
Dim TargetCounters(3) As Integer
Dim TargetNames(3) As String
TargetNames(0) = "Co"
TargetNames(1) = "Od"
TargetNames(2) = "Th"
TargetNames(3) = "Ca"
Dim i As Integer
Dim shSource As Worksheet
Dim shTargets(3) As Worksheet
Set shSource = ThisWorkbook.Sheets("Data input")
For i = 0 To 3
Set shTargets(i) = ThisWorkbook.Sheets(TargetNames(i))
If shTargets(i).Cells(2, 1).Value = "" Then
TargetCounters(i) = 2
Else
TargetCounters(i) = shTargets(i).Cells(2, 1).CurrentRegion.Rows.Count + 2
End If
Next i
i = 2
Dim MatchIndex As Integer
Do Until shSource.Cells(i, 1).Value = ""
Select Case shSource.Cells(i, 1).Value
Case "Co":
MatchIndex = 0
Case "Od":
MatchIndex = 1
Case "Th":
MatchIndex = 2
Case "Ca":
MatchIndex = 3
Case Else
MatchIndex = -1
End Select
If (MatchIndex = -1) Then
i = i + 1
Else
shSource.Rows(i).Copy
shTargets(MatchIndex).Cells(TargetCounters(MatchIndex), 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
TargetCounters(MatchIndex) = TargetCounters(MatchIndex) + 1
End If
Loop
End Sub
Here is a link to the excel I made. Right now I only made it to move to 4 sheets, but when working I will be able to add the rest.
https://www.dropbox.com/s/vvjt8z82xiuw9y1/Movedata.xlsm?dl=0
In short my problems is
It delete my dropdown list and it does not insert in a new free row everytime.
EDIT:
Have found out about the delete part now. Found there was function ClearContents instead of Delete.
I have excel files converted to txt. In some files, some columns are skipped. That is controlled by database:
file | remove_column
=======+===============
file1 | CASE NOTE
-------+---------------
file2 | Description
-------+---------------
file3 | Item | Address
Remove_Column has the header (1st row). If several columns should be skipped, they are delimited with '|'
I have to compare converted txt file with original excel file if they match. How can I read all columns except those showed in DB table?
I am using UFT 12.5. Reading Excel through Excel.Application or ADO.
Thnx)
UPD: Code I use:
I have columns hard-coded:
Select Case OrigFileName 'file names come from database
Case "Fees mm-yy.xls"
ColumnNames = Split("1,2,3,4,5,6,7,8,9,10,11,12,13", ",")
Case "Exp mm-yy.xls"
ColumnNames = Split("1,2,3,4,5,6,7,8,9,12,13,14,15,16,19,20", ",")
End Select
But there are 50 files, and the business might ask to remove or to add back any columns; also, new files are coming...(((
Dim fsox : Set fsox = CreateObject("Scripting.FileSystemObject")
Dim TargFileRead : Set TargFileRead = fsox.OpenTextFile(targetFile)
Dim OrgExcel : Set OrgExcel = CreateObject("Excel.Application")
OrgExcel.Workbooks.Open(originalfile)
Set vSheet = OrgExcel.WorkSheets(TabUse) 'excel sheet name, comes from database
print vSheet.UsedRange.Rows.Count
For rc = 1 To vSheet.UsedRange.Rows.Count
For coc = 0 To UBound(ColumnNames) 'column names hard-coded
cc = cInt(ColumnNames(coc))
vtext = vSheet.cells(rc,cc)
If NOT(vtext=ChrW(9)) Then
If vstring="" Then
vstring=vtext
Else
vstring = vstring&vbTab&vtext
End If
End If
If len(vstring)>0 Then
TargFileText = TargFileRead.ReadLine
Do
If Left(TargFileText, 1)=ChrW(9) Then
TargFileText = MID(TargFileText, 2)
Else
Exit Do
End If
Loop
Do
If RIGHT(TargFileText, 1)=ChrW(9) Then
TargFileText= mid(TargFileText,1,len(TargFileText)-1)
Else
Exit Do
End If
Loop
TargFileStr = Trim(TargFileText)
If trim(vstring) = trim(TargFileStr) Then
' print "match"
Else
print "-=Not Match=-"&VBNewLine&"txt:::"&trim(TargFileStr)&VBNewLine&"xls:::"&trim(vstring)
End If
End If
Next
I would suggest to replace the Switch statement with a function call that gives you the relevant columns for the sheet as an array. The logic which column is allowed is then put in another function. That should make the logic more flexible than fixed columns.
Function getColumns(OrigFileName as String) As String()
Dim lastCol As Integer
Dim ColumnNumbers As String
lastCol = Sheets(OrigFileName).UsedRange.Columns.Count
For col = 1 To lastCol
If isColumnAllowed(OrigFileName, Sheets(OrigFileName).Cells(1, col)) Then
ColumnNumbers = ColumnNumbers & IIf(Len(ColumnNumbers) = 0, "", ",") & col
End If
Next
getColumns = Split(ColumnNumbers, ",")
End Function
Function isColumnAllowed(ByVal OrigFileName As String, columnName As String) As Boolean
Select Case OrigFileName
Case "file1"
Forbidden = Split("CASE NOTE", "/")
Case "file2"
Forbidden = Split("Description", "/")
Case "file3"
Forbidden = Split("Item/ Address", "/")
End Select
isColumnAllowed = (UBound(Filter(Forbidden, columnName)) = -1)
End Function
This is what I have now and is working:
If LEN(ColumnToRemove)>0 Then
ColumnToRemoveCol = split(ColumnToRemove, "|") 'set collection of header strings to skip column
For L = 1 To vSheet.UsedRange.Columns.Count
For x = 0 to UBound(ColumnToRemoveCol)
AddCol = 0 'ColumnToRemoveCol can have more than 1 item, that may cause any column to be added more than once; we will use the true/false logic via 0 and 1 to avoid that doubling
If vSheet.cells(1, l)=ColumnToRemoveCol(x) Then
AddCol = AddCol + 1
End If
Next
If AddCol =0 Then ColumnNumbers = ColumnNumbers&","&L
Next
Else
For L = 1 To vSheet.UsedRange.Columns.Count
ColumnNumbers = ColumnNumbers&","&L
Next
End If
If LEFT(ColumnNumbers, 1)="," Then ColumnNumbers=MID(ColumnNumbers, 2)
If RIGHT(ColumnNumbers, 1)="," Then ColumnNumbers=MID(ColumnNumbers, 1, LEN(ColumnNumbers)-1)
Printing the columns for first excel file in my case gives the next line:
ColumnNumbers: 1,2,3,4,5,6,7,8,10,11,12,15,16,17
Further usage:
getColumns = Split(ColumnNumbers, ",")
For rc = 1 To vSheet.UsedRange.Rows.Count
For coc = 0 To UBound(getColumns)
cc = cInt(getColumns(coc))
vtext = vSheet.cells(rc,cc)
.....
Next
Next
I am trying to do the following: I want to store different areas (marked in yellow) in a string. The first yellow area is F7:G8, second is I7:J8 and so on, such that the string becomes: "F7:G8,I7:J8,L7:M8,F10:G11,I10:J11, L10:M11".
So in this example I have three areas to the right, and two down. The number of areas to the right and downwards may vary, therefore I want to make a code where I only have to specify how many areas to the right and downwards. Note that the first area always is F7:G8, so this I can use as a reference. Now, how many columns one skips before next area might vary, and also how many rows one skips before next area might vary. So this I need to take into account.
I have the following VBA code:
Sub test()
'
' test Makro
'
'
Dim i As Integer, j As Integer
k = 2 'areas downwards'
l = 3 'areas rightwards'
Dim area As String
Let area = "F7:G8" 'first area, always the same'
Dim Upper_letter As String
Let Upper_letter = "F"
Dim Upper_nr As String
Let Upper_nr = "7"
Dim Lower_letter As String
Let Lower_letter = "G"
Dim Lower_nr As String
Let Lower_nr = "8"
For i = 1 To k
For j = 1 To l
area = area & "," & Upper_letter & Upper_nr ":" & Lower_letter & Lower_number
'How do I add 3 letters to both Upper_letter and Lower_letter after each iteration of j?'
Next j
upper_nr = upper_nr + 3 'after each iteration of i, add 3'
lower_nr = lower_nr + 3 'after each iteration of i, add 3'
Next i
End Sub
So I fail to see how I can add letters, in the innermost loop.
Please try this:
Sub ErosRam()
Dim i&, j&, area$, k As Range, r As Range
Const COL_PERIOD = 3
Const ROW_PERIOD = 3
Const REPS_HORIZONTAL = 3
Const REPS_VERTICAL = 2
Set r = [f7:g8]
Set k = r
For i = 0 To REPS_VERTICAL - 1
For j = 0 To REPS_HORIZONTAL - 1
Set k = Union(k, r.Offset(i * ROW_PERIOD, j * COL_PERIOD))
Next
Next
area = k.Address(0, 0)
MsgBox area
End Sub
You can edit the Const lines at the top to change the period and the number of repetitions.
I'm building an Excel program at work so that collegues can view their upsells. What i'm stuck on is the population of the listbox.
When I populate the listbox it returns all rows. What I need it too return though is all rows where the name in the E column matches with the one contained in the public variable.
I searched all over to try and find a solution but have not had any luck.
Any help would be greatly appreciated as this is starting to bug me now.
Public Sub UserForm_Initialize()
var_associate = "Kirsty"
Dim var_nextline As Integer
var_nextline = 1
x = "a"
Do While x <> ""
x = Cells(var_nextline, 2)
If x <> var_associate Then
var_nextline = var_nextline + 1
Else
Me.lsb_upsell.AddItem(var_nextline, 2).Value
var_nextline = var_nextline + 1
End If
Loop
End Sub
x = Cells(var_nextline, 2)
should give an error, as the right-hand side returns the cell object, not the value contained in the cell, and assignment of objects must be done by using Set. Anyway, it is not what you want to have. Try
x = Cells(var_nextline, 2).Value2
Remark: You could improve your code:
Public Sub UserForm_Initialize()
Dim var_associate As String
var_associate = "Kirsty"
Dim var_nextline As Integer
var_nextline = 1
Dim x As String
Do
x = Cells(var_nextline, 2).Value2
If x = "" Then Exit Loop
If x = var_associate Then
Me.lsb_upsell.AddItem(x).Value
End If
var_nextline = var_nextline + 1
Loop
End Sub
Second remark: Where is Cells initialized (e.g. with Set Cells = ActiveSheet.Cells)? Add Option Explicit at the top of your file in order to get error messages for undeclared variables. Do you mean something like
ActiveSheet.Cells(var_nextline, 2).Value
?