I have an excel worksheeet which has a number of columns, typically from A to AZ. I've written something in VBA which is supposed to arrange and clean this worksheet by calling other subroutines, each which perform an individual task such as formatting, deleting rows, inserting new columns and moving and renaming existing ones.
I'm very new to VBA, so a lot of what I have written is what I've managed to find on here or google. I'm not sure whether the way I have written this is the best way of performing the task.
The problem I have is that the first part one of the subs (arrangeColumns) which is supposed to insert a new column at A somtimes works. The other times it appears to copy the entire worksheet and duplicate it so that my columns now go from A - AZ and are duplicated again from BA - CZ.
From what what little knowledge I have I've managed to find out that when I run this sub on its own it does work, however when this sub is called from my main part it doesnt peform as it should.
Apart from the very first column not being inserted correctly the rest of the code seems to work. Any help or suggestions welcome! thanks
Sub ArrangeColumns()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("test")
'inserts Index column at A. This is the part that seems to fail and duplicates the worksheet
ws.Range("A1").EntireColumn.Insert
ws.Range("A1").Value = "Index"
'identifies last column
Dim lastColumn As Long
lastColumn = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).column
'Finds the column Timestamp: Time and moves to B, renames to Date
Dim column As Range
For Each column In ws.Range("A1:" & Split(ws.Cells(1, lastColumn).Address, "$")(1) & "1").Cells
If column.Value = "Timestamp: Time" Then
column.EntireColumn.Cut
ws.Range("B1").Insert shift:=xlToRight
ws.Range("B1").Value = "Date"
Exit For
End If
Next column
'inserts Time column at C
ws.Range("C1").EntireColumn.Insert
ws.Range("C1").Value = "Time"
'inserts blank column at D
ws.Range("D1").EntireColumn.Insert
ws.Range("D1").Value = "Blank"
'finds the column Body and moves to E
For Each column In ws.Range("A1:" & Split(ws.Cells(1, lastColumn).Address, "$")(1) & "1").Cells
If column.Value = "Body" Then
column.EntireColumn.Cut
ws.Range("E1").Insert shift:=xlToRight
Exit For
End If
Next column
'find the From column and moves to F
For Each column In ws.Range("A1:" & Split(ws.Cells(1, lastColumn).Address, "$")(1) & "1").Cells
If column.Value = "From" Then
column.EntireColumn.Cut
ws.Range("F1").Insert shift:=xlToRight
ws.Range("F1").Value = "From User"
Exit For
End If
Next column
'inserts From Attributed column at G
ws.Range("G1").EntireColumn.Insert
ws.Range("G1").Value = "From Attributed"
'find th To column and moves to H, renames to To User
For Each column In ws.Range("A1:" & Split(ws.Cells(1, lastColumn).Address, "$")(1) & "1").Cells
If column.Value = "To" Then
column.EntireColumn.Cut
ws.Range("H1").Insert shift:=xlToRight
ws.Range("H1").Value = "To User"
Exit For
End If
Next column
'inserts To Attributed at I
ws.Range("I1").EntireColumn.Insert
ws.Range("I1").Value = "To Attributed"
'finds Participants column and moves to J
For Each column In ws.Range("A1:" & Split(ws.Cells(1, lastColumn).Address, "$")(1) & "1").Cells
If column.Value = "Participants" Then
column.EntireColumn.Cut
ws.Range("J1").Insert shift:=xlToRight
Exit For
End If
Next column
'Finds Source column and moves to K
For Each column In ws.Range("A1:" & Split(ws.Cells(1, lastColumn).Address, "$")(1) & "1").Cells
If column.Value = "Source" Then
column.EntireColumn.Cut
ws.Range("K1").Insert shift:=xlToRight
Exit For
End If
Next column
End Sub
Sub deleteFirstRow()
'deletes the first row of the worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("test")
ws.Rows(1).Delete
End Sub
Sub convertToRange()
'loops throught the worksheet to find all tables and converts to range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("test")
Dim table As ListObject
For Each table In ws.ListObjects
table.Range.Copy
table.Unlist
Next table
End Sub
Sub clearFilter()
'removes all filters on activesheet
On Error Resume Next
ActiveSheet.ShowAllData
End Sub
Sub formatting()
'if this sub is called after cleaning the columns, then the index will be blank. This uses the column titled '#' to find the lastrow
Dim lastRow As Long
Dim lastColumn As Long
Dim col As Range
Set col = Rows(1).Find("#", LookIn:=xlValues, lookat:=xlWhole)
lastRow = Cells(Rows.Count, col.column).End(xlUp).Row
lastColumn = Cells(1, columns.Count).End(xlToLeft).column
Dim rngAll As Range
Set rngAll = Range(Cells(1, 1), Cells(lastRow, lastColumn))
Dim rngTopRow As Range
Set rngTopRow = Range(Cells(1, 1), Cells(1, lastColumn))
Dim rngSecondRowDown As Range
Set rngSecondRowDown = Range(Cells(2, 1), Cells(lastRow, lastColumn))
With rngAll
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
.Borders.ColorIndex = xlAutomatic
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).Weight = xlThin
.Borders(xlInsideHorizontal).ColorIndex = xlAutomatic
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideVertical).ColorIndex = xlAutomatic
End With
'sets the colour, font and row size of the first row
With rngTopRow
.Interior.Color = RGB(48, 84, 150)
.Font.Color = vbWhite
.Font.Bold = True
.RowHeight = 40
End With
'sets colour, borders and row size of rows 2 to lastrow
With rngSecondRowDown
.Interior.Color = RGB(255, 255, 255)
.RowHeight = 50
End With
End Sub
Sub splitDateTime()
'if this sub is called after cleaning the columns, then the index will be blank. This uses the column titled '#' to find the lastrow
'Splits the values in column B from 'dd/mm/yyyy hh:mm:ss' by space and moves 'hh:mm:ss' to column c
Dim lastRow As Long
Dim col As Range
Set col = Rows(1).Find("#", LookIn:=xlValues, lookat:=xlWhole)
lastRow = Cells(Rows.Count, col.column).End(xlUp).Row
For i = 2 To lastRow
Cells(i, 3).Value = Mid(Cells(i, 2).Value, 12, 16)
Cells(i, 2).Value = Left(Cells(i, 2).Value, 10)
Next i
End Sub
Sub columnWidth()
columns("a").columnWidth = 15
columns("b").columnWidth = 11
columns("c:d").columnWidth = 15
columns("e").columnWidth = 30
columns("f:i").columnWidth = 22
columns("j").columnWidth = 40
End Sub
Sub applyFilter()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("test")
Dim rngAll As Range
Dim lastRow As Long
Dim lastColumn As Long
Dim col As Range
Set col = Rows(1).Find("#", LookIn:=xlValues, lookat:=xlWhole)
lastRow = Cells(Rows.Count, col.column).End(xlUp).Row
lastColumn = Cells(1, columns.Count).End(xlToLeft).column
Set rngAll = Range(Cells(1, 1), Cells(lastRow, lastColumn))
rngAll.AutoFilter
End Sub
Sub arrangeWorksheet()
Call clearFilter
Call deleteFirstRow
Call convertToRange
Call ArrangeColumns
Call formatting
Call splitDateTime
Call columnWidth
Call applyFilter
End Sub
There is a bunch of repeated logic/steps in your ArrangeColumns which could be pushed out into a separate reusable method.
For example:
Sub arrangeWorksheet()
Call ArrangeColumns
End Sub
Sub ArrangeColumns()
Dim ws As Worksheet, rwHeaders As Range
Set ws = ThisWorkbook.Sheets("test")
Set rwHeaders = ws.Rows(1) 'headers are here
MoveOrAddColumn rwHeaders, "", "Index", "A"
MoveOrAddColumn rwHeaders, "Timestamp: Time", "Date", "B"
MoveOrAddColumn rwHeaders, "", "Time", "C"
MoveOrAddColumn rwHeaders, "", "Blank", "D"
MoveOrAddColumn rwHeaders, "Body", "", "E"
MoveOrAddColumn rwHeaders, "From", "From User", "F"
MoveOrAddColumn rwHeaders, "", "From Attributed", "G"
MoveOrAddColumn rwHeaders, "To", "To User", "H"
MoveOrAddColumn rwHeaders, "", "To Attributed", "I"
MoveOrAddColumn rwHeaders, "Participants", "", "J"
MoveOrAddColumn rwHeaders, "Source", "", "K"
End Sub
'With all headers in range `rwHeaders`...
'Move a column named `existingColName` to `destColLetter` (if existingColName is supplied)
'Otherwise insert a new column at position `destColLetter`
'Moved/inserted column is given header `newColName` (if supplied)
Sub MoveOrAddColumn(rwHeaders As Range, existingColName, newColName, destColLetter)
Dim m, colRng As Range, f As Range, cDest As Range, moving
Set cDest = rwHeaders.Columns(destColLetter) 'destination if moving, or new column
moving = Len(existingColName) > 0
If moving Then 'moving an existing column?
Set f = rwHeaders.Find(what:=existingColName, lookat:=xlWhole)
If f Is Nothing Then
MsgBox "Column header '" & existingColName & "' not found!"
Exit Sub
Else
If f.column <> cDest.column Then 'check if already in the requested postion
cDest.EntireColumn.Insert shift:=xlToRight
Set cDest = cDest.Offset(0, -1) 're-point reference
f.EntireColumn.Copy cDest
f.EntireColumn.Delete
End If
End If
Else
cDest.EntireColumn.Insert shift:=xlToRight
Set cDest = cDest.Offset(0, -1) 're-point reference
End If
If Len(newColName) > 0 Then cDest.Value = newColName
End Sub
Related
I have searched quite a bit for this but keep finding where people want to copy to another sheet and that's not what I want. I want to just duplicate a column labeled "Student ID" since it isn't always in column D and to reference the Active Sheet since the sheet isn't always named Sheet1. The additional code then adds a 0 to the end of the data in the new duplicated column and labels the new column "Patron". I am fairly new to VBA so struggling with this.
Range("D:D").Copy
Range("E:E").Insert
Range("E1").Value = "PATRON"
Range("IV1") = 10
Range("IV1").Copy
Range("E1:E" & Range("E" & Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValues, xlPasteSpecialOperationMultiply
Range("IV1").Delete xlShiftUp
End Sub
Something like the following could work:
Option Explicit
Public Sub Example()
DuplicateColumn ThisWorkbook.ActiveSheet, "Student ID", "PATRON"
End Sub
Public Sub DuplicateColumn(ByVal ws As Worksheet, ByVal HeaderName As String, ByVal NewColumnName As String)
' find the header name
Dim ColumnFound As Range
Set ColumnFound = ws.Rows(1).Find(What:=HeaderName, _
After:=ws.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
' check if it was found
If ColumnFound Is Nothing Then
MsgBox "Column '" & HeaderName & "' was not found.", vbCritical
Exit Sub
End If
' copy that column
With ColumnFound.EntireColumn
.Copy
.Offset(ColumnOffset:=1).Insert
End With
' give the new column a new name
ColumnFound.Offset(ColumnOffset:=1).Value = NewColumnName
' add 0 at the end of that column
ws.Cells(ws.Rows.Count, ColumnFound.Column + 1).End(xlUp).Offset(RowOffset:=1).Value = 0
End Sub
This code finds the column labeled "Student ID" and inserts a new column then copies the data to the new column. Since I'm not sure about what the rest of the code does, I'll leave that to you. Also, to a a zero at the endd of a cell 's data, just do something like cells(row, Col+1).value = cells(row, Col+1).value & "0"
Set sht = ActiveSheet 'set variable to active sheet
' Finds the column NUMBER for Student ID
Col = sht.Rows(1).Find(What:="Student ID", LookIn:=xlValues, LookAt:=xlWhole).Column
Columns(Col + 1).Insert 'insert new column
Columns(Col).Copy Columns(Col + 1) 'copy Student ID column data to new column
Cells(1, Col + 1).Value = "PATRON" 'add header to new column
Use Find to locate header and Concatenate to add the zero.
Option Explicit
Sub macro1()
Const COL_NAME = "Student ID"
Dim ws As Worksheet, rng As Range
Dim r As Long, c As Long, LastRow As Long
Set ws = ActiveSheet
Set rng = ws.Cells.Find(COL_NAME, LookIn:=xlValues, lookat:=xlWhole)
If rng Is Nothing Then
MsgBox "Could not locate column '" & COL_NAME & "'", vbCritical
Exit Sub
Else
r = rng.Row
c = rng.Column
LastRow = ws.Cells(Rows.Count, c).End(xlUp).Row
ws.Columns(c + 1).Insert
ws.Cells(r, c + 1) = "PATRON"
Set rng = ws.Cells(r + 1, c + 1).Resize(LastRow - r)
rng.FormulaR1C1 = "=CONCATENATE(RC[-1],0)"
'rng.Value2 = rng.Value2 'uncomment if you want values not fomulae
End If
End Sub
I am trying to take the output from a solver model and condense it into a summary report in another sheet. The Solver screen will be lost each time I run it on new data.
My solver screen looks like this
Solver screenshot. The ideal report output will be this table. Notice that January only has two truckloads (TLs) as Solver output (IF(E4:N4=True,Include TL,n/a). So, the new report should skip TLs #3,4,5 (G4:I4) and fill in the table with next valid output (column J). I will always want to associate the unit quantity (E:N) with a product name (D) in the new report.
I am a super novice VBA user. Here is how far I have got in my VBA to accomplish this:
Sub TL_Report()
Dim c As Range
For Each c In ActiveSheet.Range("e5:e30")
If c.Value <> 0 Then
Worksheets("TL_Report").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 2).Value = Range(c.Offset(0, -1), c).Value
End If
Next c
End Sub
I can figure out how to loop through each column in the solver, but I cannot figure out how to have the new report get reformatted without blanks entries. Any advice on how to write this? Thank you.
According to the data avaiable, i've created this subroutine:
Sub SubReport()
'Declarations.
Dim WksSource As Worksheet
Dim WksReport As Worksheet
Dim WksWorksheet01 As Worksheet
Dim RngMonths As Range
Dim RngTrucks As Range
Dim RngProductList As Range
Dim RngValues As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim DblCounter01 As Integer
Dim DblCounter02 As Integer
'Setting WksSource.
Set WksSource = Sheets("TL_Solver")
'Referring to WksSource.
With WksSource
'Setting RngMonths.
Set RngRange01 = .Range("E2")
DblCounter01 = Excel.WorksheetFunction.Min(RngRange01.End(xlToRight).Column, _
.Cells(RngRange01.Row, .Columns.Count).End(xlToLeft).Column _
)
Set RngMonths = .Range( _
RngRange01, _
.Cells(RngRange01.Row, DblCounter01) _
)
'Setting RngTrucks.
Set RngRange01 = .Range("E3")
DblCounter01 = Excel.WorksheetFunction.Min(RngRange01.End(xlToRight).Column, _
.Cells(RngRange01.Row, .Columns.Count).End(xlToLeft).Column _
)
Set RngTrucks = .Range( _
RngRange01, _
.Cells(RngRange01.Row, DblCounter01) _
)
'Setting RngProductList.
Set RngRange01 = RngTrucks.Resize(1, 1).Offset(2, -1)
DblCounter01 = Excel.WorksheetFunction.Min(RngRange01.End(xlDown).Row, _
.Cells(.Rows.Count, RngRange01.Column).End(xlUp).Row _
)
Set RngProductList = .Range( _
RngRange01, _
.Cells(DblCounter01, RngRange01.Column) _
)
'Setting RngValues.
Set RngRange01 = .Cells(RngProductList.Row, RngTrucks.Column)
Set RngValues = RngRange01.Resize(RngProductList.Rows.Count, RngTrucks.Columns.Count)
End With
'Creating a new worksheet for the report.
Set WksReport = ActiveWorkbook.Sheets.Add(After:=WksSource)
'Counting other existing reports if any.
DblCounter01 = 0
For Each WksWorksheet01 In WksReport.Parent.Worksheets()
If Left(WksWorksheet01.Name, 7) = "Report " Then
DblCounter01 = DblCounter01 + 1
End If
Next
'Renaming the current report.
DblCounter02 = DblCounter01
On Error Resume Next
Do Until WksReport.Name = "Report " & DblCounter01
DblCounter01 = DblCounter01 + 1
WksReport.Name = "Report " & DblCounter01
If DblCounter01 - DblCounter02 > 1000 Then GoTo CP_FAILED_RENAMING
Loop
CP_FAILED_RENAMING:
On Error GoTo 0
'Setting RngTarget.
Set RngTarget = WksReport.Range("A1")
'Covering each column in RngValues.
For DblCounter01 = 1 To RngValues.Columns.Count
'Checking if there is any value to report.
If Excel.WorksheetFunction.Sum(RngValues.Columns(DblCounter01).Cells) <> 0 Then
'Inserting the data for the first row of the report's chapter.
With RngTarget
.Offset(0, 1).Value = "Truck #"
.Offset(0, 2).Value = Split(RngTrucks.Cells(1, DblCounter01), "#")(1)
.Offset(0, 3).Value = "Delivery"
If WksSource.Cells(RngMonths.Row, RngTrucks.Columns(DblCounter01).Column).Value = "" Then
.Offset(0, 4).Value = WksSource.Cells(RngMonths.Row, RngTrucks.Columns(DblCounter01).Column).End(xlToLeft).Value
Else
.Offset(0, 4).Value = WksSource.Cells(RngMonths.Row, RngTrucks.Columns(DblCounter01).Column).Value
End If
.Offset(1, 1).Value = "Product"
.Offset(1, 2).Value = "Quantity"
End With
'Offsetting RngTarget by 2 rows in order to enter the data.
Set RngTarget = RngTarget.Offset(2, 0)
'Covering each value in the given column of RngValues.
DblCounter02 = 1
For Each RngRange01 In RngValues.Columns(DblCounter01).Cells
'Checking if the value is not 0.
If RngRange01.Value <> 0 Then
'Inserting the data.
With RngTarget
.Value = DblCounter02
.Offset(0, 1).Value = WksSource.Cells(RngRange01.Row, RngProductList.Column).Value
.Offset(0, 2).Value = RngRange01.Value
End With
DblCounter02 = DblCounter02 + 1
'Offsetting RngTarget to the next row of the report.
Set RngTarget = RngTarget.Offset(1, 0)
End If
Next
'Offsetting RngTarget by 1 row for the next chapter.
Set RngTarget = RngTarget.Offset(1, 0)
End If
Next
'Autofitting the second column of the report.
RngTarget.Offset(0, 1).EntireColumn.AutoFit
End Sub
It dynamically determines the size of the data to process (starting from given cells), it creates a new sheet renamed as "Report n" (based of the n pre-existing sheet already named "Report n") and insert the data as requested.
I have a spreadsheet that is updated regularly. The user will update two columns on sheet(create) with container type (this is the header name) and the quantity, which will be transferred to sheet(Tracking). I am trying to figure out how to search sheet2(Tracking for existing headers (container types), if found then quantity will be updated within that column for the next available row. If header is not found, therefore a new column is added to the right with that new header name, as well as updating the quantity.
I did find some good example such as the below. However not sure how to apply it. Maybe there could be a way to loop it to search the headers.
Sub TrackR()
Dim cl As Range
For Each cl In Range("1:1")
If cl = sheets(“Create”).range(“J11:J36”) Then
cl.EntireColumn.Insert Shift:=xlToRight
End If
cl.Offset(0, 1) = "New Conatainer Name"
Next cl
Application.ScreenUpdating = False
Sheets("Tracking").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Date
'Trailer No.
Sheets("Create").Range("L8").Copy
Sheets("Tracking").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'total container qty
Sheets("Create").Range("G43").Copy
Sheets("Tracking").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Supplier
Sheets("Create").Range("K4").Copy
Sheets("Tracking").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'quantities
Sheets("Create").Range("L11").Copy
Sheets("Tracking").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Create").Range("L12").Copy
Sheets("Tracking").Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Create").Range("L13").Copy
Sheets("Tracking").Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Create").Range("L14").Copy
Sheets("Tracking").Range("H" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Create").Range("L15").Copy
Sheets("Tracking").Range("I" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
Not sure, try this ... ~
Sub TrackB()
Dim wsCreat As Worksheet: Set wsCreat = Sheets("Create")
Dim wsTracking As Worksheet: Set wsTracking = Sheets("Tracking")
Dim cl As Range, lastHCell As Range, header As Range, i As Integer, j As Integer,k as integer, str As Variant
With wsTracking
Set header = .[a1:xx1]: Set lastHCell = header.End(xlToRight)
iLstRow = .[a10000].End(xlUp).Offset(1, 0).Row
'Update default data [A:D]
.Range("A" & iLstRow) = Date
For Each str In Array("L8", "C4", "G43")
.Cells(iLstRow, i + 2) = wsCreat.Range(str): i = i + 1
Next
'add Column if not Match
For Each cl In wsCreat.[B11:B37, E11:E37]
Dim k: k = Application.Match(cl, header, 0)
If IsError(k) And cl <> vbNullString Then _
lastHCell.Offset(0, 1).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=True: _
Set lastHCell = lastHCell.Offset(0, 1): lastHCell.Value2 = cl
Next cl
'Update input Data
i = 5
Dim arr As Variant: arr = Array("B11:B37", "E11:E37")
Dim arrResult As Variant: arrResult = Array("C10" , "F10")
Dim cell As Range: k = 0
For k = 0 To UBound(arr)
j=1
For Each cell In wsCreat.Range(arr(k)).Cells
If cell.Value2 <> vbNullString Then
.Cells(iLstRow, Application.Match(cell, header, 0)) = wsCreat.Range(arrResult(k)).Offset(j, 0)
End If
j = j + 1
Next cell
Next
End With
End Sub
Untested but something like this should work:
Sub TrackR()
Dim wsTrack As Worksheet, wsCreate As Worksheet, cont, qty, h As Range
Dim c As Range, m, rw As Range, rngHeaders As Range, col As Long
Set wsCreate = ThisWorkbook.Worksheets("Create")
Set wsTrack = ThisWorkbook.Worksheets("Track")
'get the next empty row on the Tracking sheet
Set rw = wsTrack.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
'fill in the common cells in the row
rw.Cells(1).Value = Date
rw.Cells(2).Value = wsCreate.Range("L8").Value
rw.Cells(3).Value = wsCreate.Range("K4").Value
rw.Cells(4).Value = wsCreate.Range("G43").Value
'now loop over the containers and add each one
Set rngHeaders = wsTrack.Cells(1, "E").Resize(1, 5000) 'or whatever would cover your data
For Each c In wsCreate.Range("J11:J36").Cells
cont = c.Value
qty = c.Offset(0, 2).Value
If Len(cont) > 0 And Len(qty) > 0 Then
m = Application.Match(cont, rngHeaders, 0) 'any existing match ?
If IsError(m) Then
'no match - find the first empty cell and add the container
Set h = rngHeaders.Cells(rngHeaders.Cells.Count).End(xlToLeft).Offset(0, 1)
h.Value = cont
col = h.Column 'column number for the added header
Else
'matched: get the column number
col = rngHeaders.Cells(m).Column
End If
rw.Cells(col).Value = qty '<< add the quantity
End If
Next c
End Sub
I have data where I have many column headers. One of the header is "Text" and one other header is "Value Date". I want to combine the values contained in every row between these columns in another column row-wise.
The problem is the number of columns between these two headers is not constant. It changes with every new ledger I export. So I want my code to be dynamic in such a way that it will identify the column of "Text" and then it will identify the column of "Value Date" and combine everything between in another column row-wise.
This is where I have reached with my code but I don't know why it's not working. I have been trying this for last 3 days only to get nowhere. When I run this code, the result which I get is "TextColumnNo:ValueColumnNo".
Sub TextJoin()
Dim TextColumnNo As Range
Dim ValueColumnNo As Range
Range("A1").Select
ActiveCell.EntireRow.Find("Text").Activate
Set TextColumnNo = Range(ActiveCell.Address(False, False))
Range("A1").Select
ActiveCell.EntireRow.Find("Value").Activate
Set ValueColumnNo = Range(ActiveCell.Address(False, False))
ActiveCell.Offset(1, -1).Select
Application.CutCopyMode = False
ActiveCell.Value = Application.WorksheetFunction.TextJoin(" ", True, _
"TextColumnNo:ValueColumnNo")
ActiveCell.Select
Selection.AutoFill Destination:=ActiveCell.Range("A1:A8524")
ActiveCell.Range("A1:A8524").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
You would need 2 loops for this. One looping through all rows and one looping through the columns to combine the text for each row.
Note that you need to adjust some things like sheet name and output column here.
Option Explicit
Public Sub TextJoin()
Dim ws As Worksheet
Set ws = Worksheets("Sheet1") 'define a worksheet
'find start
Dim FindStart As Range
Set FindStart = ws.Rows(1).Find("Text")
If FindStart Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find end
Dim FindEnd As Range
Set FindEnd = ws.Rows(1).Find("Value Date")
If FindEnd Is Nothing Then
MsgBox "start not found"
Exit Sub
End If
'find last used row in column A
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim iRow As Long
For iRow = 2 To lRow 'loop through all rows (2 to last used row)
Dim CombinedText As String
CombinedText = vbNullString 'initialize/reset variable
Dim iCol As Long 'loop through columns for each row (from start to end column)
For iCol = FindStart.Column To FindEnd.Column
CombinedText = CombinedText & ":" & ws.Cells(iRow, iCol).Text 'combine values
Next iCol
ws.Range("Z" & iRow) = CombinedText 'write values in column Z
Next iRow
End Sub
Sub TextJoin()
Dim ColRefText As Long
Dim ColRefValueDate As Long
Const firstcol = "Text"
Const secondcol = "Value Date"
Dim r As Range
Set r = Rows(1).Cells.Find(firstcol)
If Not r Is Nothing Then
ColRefText = r.Column
Set r = Rows(1).Cells.Find(secondcol)
If Not r Is Nothing Then
ColRefValueDate = r.Column
End If
End If
If ColRefValueDate + ColRefText > 0 Then
With Cells(2, Worksheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
.Formula = Replace("=" & Cells(2, ColRefText).AddressLocal & "&" & Cells(2, ColRefValueDate).AddressLocal, "$", "")
.Copy Range(.Address, Cells(ActiveSheet.UsedRange.Rows.Count, .Column).Address)
End With
End If
End Sub
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.