I'm populating cells using a For loop, with the results looking like this:
I'd like to format each set as a table, with each table name reflecting the number of the set (so "Table 1", "Table 2" etc). I thought I could do this with the VBA code:
> ws.ListObjects.Add(xlSrcRange, ws.Range(ws.Cells(start_row,
> start_column), ws.Cells(table_height, table_width)), , xlYes).Name =
> "Table" & t_count
but I get the error message:
Run-time error '1004':
A table can't overlap another table.
Any ideas how I can get round this?
Thanks in advance.
Please, try the next way. There must exist minimum one empty row between the two consecutive ranges to become tables. There must not exist any gap/empty cell in the first rage column:
Sub createTablesFromRanges()
Dim ws As Worksheet, lastR As Long, start_row As Long, last_row As Long
Dim start_column As Long, last_col As Long, t_count As Long, i As Long
Set ws = ActiveSheet
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row 'calculated based on A:A column
start_column = 1 'it can be different, if not the first column (A:A)
t_count = 1 'first number before loop incrementation
For i = 1 To lastR
start_row = i 'range starting row
last_col = ws.cells(i, ws.Columns.count).End(xlToLeft).Column 'range last column number
last_row = ws.Range("A" & i).End(xlDown).row 'range last row
'create table:
ws.ListObjects.Add(xlSrcRange, ws.Range(ws.cells(start_row, start_column), _
ws.cells(last_row, last_col)), False, xlYes).Name = "Table" & t_count
start_row = ws.cells(last_row, 1).End(xlDown).row - 1 'new starting row based on the next range header
i = start_row: t_count = t_count + 1 'increment i and t_count
If i >= lastR Then Exit For 'after the last range, start_row returns the sheet total number of rows
Next i
End Sub
Related
I am trying to do the following (please see the picture below): I have N categories in a worksheet (below just showing 2 as example), having 5 subcategories each category and I want to copy them in another worksheet but having only the subcategories, listing all the data from categories one below the others. How can I do that in VBA?
The code I am using so far :
Sub Fill_Tracker()
' Initialize the worksheets, number of rows per Offer and numbers of Offers
Dim WSS As Worksheet
Dim WSD As Worksheet
Set WSS = Sheets("Database")
Set WSD = Sheets("Data_PIVOT")
' Copy and paste values of Currency BOQ
WSS.Range("B10", WSS.Range("b10").End(xlDown)).Copy
WSD.Range("J2").PasteSpecial xlPasteValues
' Copy and paste values of USD
WSS.Range("c10", WSS.Range("c10").End(xlDown)).Copy
WSD.Range("k2").PasteSpecial xlPasteValues
' Copy and paste values of USD/Wdc
WSS.Range("d10", WSS.Range("d10").End(xlDown)).Copy
WSD.Range("l2").PasteSpecial xlPasteValues
' Copy and paste values of Rate
WSS.Range("e10", WSS.Range("e10").End(xlDown)).Copy
WSD.Range("m2").PasteSpecial xlPasteValues
' Copy and paste values of Description
WSS.Range("f10", WSS.Range("f10").End(xlDown)).Copy
WSD.Range("n2").PasteSpecial xlPasteValues
Thanks for all the help.
Please, try the next code. It should be very fast for a big range. It avoids iteration between each row, it uses arrays and array slices:
Sub Fill_Tracker()
Dim WSS As Worksheet, WSD As Worksheet, lastRow As Long, lastCol As Long, lastR As Long
Dim arr, arrCateg, strC As String, strCol As String, i As Long, lastRWSD As Long, c As Long
Set WSS = Sheets("Database")
Set WSD = Sheets("Data_PIVOT")
lastRow = WSS.UsedRange.Rows.count 'maximum number of rows to be processed
lastCol = WSS.cells(2, WSS.Columns.count).End(xlToLeft).Column 'no of columns
lastRWSD = WSD.Range("A" & WSD.Rows.count).End(xlUp).row + 1 'last empty row
arr = WSS.Range("A3", WSS.cells(lastRow, lastCol)).Value 'put the sheet content in an array
c = 5 'a variable to increment in order to build the column to be copied headers
For i = 1 To UBound(arr, 2) Step 5
strC = Split(cells(1, i).Address, "$")(1) 'first column letter
strCol = strC & ":" & Split(cells(1, c).Address, "$")(1) 'string of involved columns letter
lastR = WSS.Range(strC & WSS.Rows.count).End(xlUp).row - 2 'last row for the above range
c = c + 5 'increment the columns range
'make a slice for the necessary array rows and columns!
arrCateg = Application.index(arr, Evaluate("row(1:" & lastR & ")"), Evaluate("COLUMN(" & strCol & ")"))
'drop the array at once:
WSD.Range("A" & lastRWSD).Resize(UBound(arrCateg), 5).Value = arrCateg
lastRWSD = WSD.Range("A" & WSD.Rows.count).End(xlUp).row + 1 'last row where next time the array will be dropped
Next
End Sub
I would like to create a VBA, to copy my data in "RAW", to paste into sheet "summary" by the specific column arrangement in my "summary" sheet.
for example, if sheet "summary" column A is COUNTER CODE, then copy the data from sheet "RAW" which the data is in B2-B5 and paste into my sheet "summary" A2-A5
I tried to use the below VBA, which it works. but in the event if the column data in "RAW" is different, i will not be getting the correct data.
Sub TRANSFERDATA()
Dim LASTROW As Long, EROW As Long
LASTROW = Worksheets("RAW").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LASTROW
Worksheets("RAW").Cells(i, 1).Copy
EROW = Worksheets("summary").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 2)
Worksheets("RAW").Cells(i, 2).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 1)
Worksheets("RAW").Cells(i, 3).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 4)
Worksheets("RAW").Cells(i, 4).Copy
Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 3)
Next i
End Sub
Thanks!
summary
RAW
Test the next code, please. Yo do not have to copy cell by cell. In the way the code is designed, it will also work for a header which is not identic with the one in 'RAW' worksheet, but 'RAW' header string is contained:
Sub TestFindCopyInPlace()
Dim shR As Worksheet, shSum As Worksheet, colHeadR As String
Dim colHS As Range, lastCol As Long, lastRow As Long, i As Long
Set shR = Worksheets("RAW")
Set shSum = Worksheets("summary")
lastCol = shR.Cells(1, Columns.count).End(xlToLeft).Column
lastRow = shR.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastCol
colHeadR = shR.Columns(i).Cells(1, 1).value
Set colHS = shSum.Rows(1).Find(colHeadR)' find the cell with the header of the one being copied
If Not colHS Is Nothing Then 'Find method will find a column containing colHeadR in its header string...
shR.Range(shR.Cells(2, i), shR.Cells(lastRow, i)).Copy Destination:=colHS.Offset(1, 0)
Else
MsgBox "The column header """ & colHeadR & """ could not be found." & vbCrLf & _
"Please check the spelling or whatever you think it is necessary..."
End If
Next i
End Sub
The code should work for as many columns your 'RAW` worksheet contains...
To make the process fully automatic, please use the following code:
Sub TRANSFERDATA()
Const rawSheet As String = "RAW"
Const summarySheet As String = "summary"
'===================================================================================
' Find the last column in both sheets
'===================================================================================
Dim rawLastCol As Integer
Dim summaryLastCol As Integer
rawLastCol = Worksheets(rawSheet).Cells(1, Columns.Count).End(xlToLeft).Column
summaryLastCol = Worksheets(summarySheet).Cells(1, Columns.Count).End(xlToLeft).Column
'===================================================================================
' Iterate over all columns in the RAW sheet and transfer data to the summary sheet
'===================================================================================
Dim col As Integer
For col = 1 To rawLastCol
'Read column header
Dim header As String
header = Worksheets(rawSheet).Cells(1, col).Value
'Find this header in the summary sheet
Dim col2 As Integer
For col2 = 1 To summaryLastCol
If Worksheets(summarySheet).Cells(1, col2).Value = header Then
'Transfer all values from RAW to the summary sheet
Dim lastRow As Integer
lastRow = Worksheets(rawSheet).Cells(Rows.Count, col).End(xlUp).row
If lastRow > 1 Then 'to handle the case where a column contains no data
'First clear previous data
Range(Worksheets(summarySheet).Cells(2, col2), Worksheets(summarySheet).Cells(lastRow, col2)).ClearContents
'Now, transform data
Dim row As Integer
For row = 2 To lastRow
Worksheets(summarySheet).Cells(row, col2).Value = Worksheets(rawSheet).Cells(row, col).Value
Next row
End If
'Break
Exit For
End If
Next col2
Next col
End Sub
This will work event if the number of columns or rows change in your sheets
I know that this row is wrong:
ws.Cells(i, "D").Resize(39).Rank_Eq(2, "2:40", 1) = ws.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
I want to rank the whole column D in column E. The numbers should be "grouped" in 39 numbers.
Private Sub CommandButton2_Click()
Dim lrow As Long
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lrow = ws.Cells(Rows.Count, "D").End(xlUp).row 'Find the last row in column D
For i = 2 To lrow Step 39 'Loop every group (group of 13 rows) in column D
ws.Cells(i, "D").Resize(39).Rank_Eq(2, "2:40", 1) = ws.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
Next i
End Sub
I think the code will do what you want. Please pay attention to the constants at the top which you have to set to suit your needs.
FirstDataRow - your data seem to start in row 2. So, don't change.
GroupSize - I tested groups of 3 rows. I think you want groups of 39 rows. Change it.
TgtClm - Your data are in column 4 (column D). No need to change now.
Once you have set these 3 constants the code is ready to run. Please try it.
Private Sub CommandButton2_Click()
' 034
Const FirstDataRow As Long = 2
Const GroupSize As Long = 3 ' change to suit
Const TgtClm As Long = 4 ' Target Column (4 = column D)
' the output will be in the adjacent column
Dim Ws As Worksheet
Dim Rng As Range ' cells in one group
Dim lRow As Long ' last used row
Dim Rstart As Long ' first row in group range
Dim Rend As Long ' last row in group range
Set Ws = ActiveWorkbook.Worksheets("Sheet1") 'Set the name of the sheet
lRow = Ws.Cells(Ws.Rows.Count, TgtClm).End(xlUp).Row 'Find the last used row
Rstart = FirstDataRow
Do
Rend = Application.Min(Rstart + GroupSize - 1, lRow)
With Ws
Set Rng = .Range(.Cells(Rstart, TgtClm), .Cells(Rend, TgtClm))
End With
Rng.Offset(0, 1).Formula = "=RANK(" & Rng.Cells(1).Address(0, 1) & _
"," & Rng.Address & ",0)"
Rstart = Rend + 1
If Rstart > lRow Then Exit Do
Loop
End Sub
Note that the final 0 in the RANK formula (here: & Rng.Address & ",0)") instructs to rank in desscending order, meaning the highest number will get the lowest rank (100 = 1, 90 = 2 etc). Change to 1 if you need the opposite order.
I do not know this topic so well, but on the webpage
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.rank_eq
Is written that expression.Rank_Eq (Arg1, Arg2, Arg3), and the
expression A variable that represents a WorksheetFunction object.
In your code it looks like a Range object.
I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub
I am looking to save the vertically saved Information for each ID (row 1) from this Worksheet:
To another Worksheet, which Looks like this:
For each column, with the ID in row 1, there are skills saved as strings. Each part (there are 3) is supposed to be saved on the second Worksheet in column B,C and D, respectively.
With the code I will post below, there is no Error. It simply doesn't do anything. When using a stop in the code, the problem seems to be that the items ID's I am trying to find (FindIDcol, FindIDrow) are simply "Nothing".
I am very new to VBA and might have a way too complicated Approach or ineffective code. However, I hope one of you can help me out here.
Thank you in advance for your help!
Here my code:
Dim wsInput As Worksheet
Set wsInput = ActiveWorkbook.Worksheets("Supplier Skills")
Dim wsOutput As Worksheet
Set wsOutput = ActiveWorkbook.Worksheets("Search Skills")
Dim IDcolumn As Range
Dim IDrow As Range
Dim lastcol As Integer
Dim lastRow As Integer
Dim NextRow As Integer
Dim FindIDcol As Range
Dim FindIDrow As Range
With wsInput
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
LastColLetter = Split(Cells(1, lastcol).Address(True, False), "$")(0)
'For every column on Input-Sheet with Data
For Each IDcolumn In wsInput.Range("A1:" & LastColLetter & "1")
'Firstly, find each ID column
FindIDcol = wsInput.Range("A1:" & LastColLetter & "1").Find(What:=IDcolumn, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FindIDcol Is Nothing Then
'Secondly, get the respective column Letter
IDcolLetter = Split(FindIDcol.Address, "$")(0)
'Thirdly, find all skills saved in rows beneath this column
lastRow = .Range(IDcolLetter & .Rows.Count).End(xlUp).row
For Each IDrow In wsInput.Range(IDcolLetter & "1:" & IDcolLetter & lastRow)
'Fourthly, get the respective row-number for each skill
FindIDrow = wsInput.Range(IDcolLetter & "2:" & IDcolLetter & lastRow).Find(What:=IDrow, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
IDrowNumber = Split(FindIDrow.Address, "$")(1)
'Fifthly, split the strings in 3 parts
Dim myElements() As String
myElements = Split(wsInput.Range(IDcolLetter & IDrowNumber).value, "\")
'Sixthly, for every skill of that supplier, copy the ID in A, CG in B, Category in C and Product in D
NextRow = wsOutput.Range("A" & Rows.Count).End(xlUp).row + 1
wsInput.Range(IDcolLetter & "1").Copy Destination:=wsOutput.Range("A" & NextRow) 'ID
wsOutput.Range("B" & NextRow) = myElements(0) 'Commodity Group
wsOutput.Range("C" & NextRow) = myElements(1) 'Category
wsOutput.Range("D" & NextRow) = myElements(2) 'Product
Next IDrow
End If
Next IDcolumn
End With
standing your shown data structure and if I correctly interpreted your goal, you can simplify your code as follows:
Option Explicit
Sub main()
Dim wsOutput As Worksheet
Dim colCell As Range, rowCell As Range
Dim outputRow As Long
Set wsOutput = Worksheets("Output") '<--| change "Output" to your actual output sheet name
outputRow = 2 '<--| initialize output row to 2 (row 1 is for headers)
With Worksheets("Input") '<--| reference input sheet (change "Input" to your actual input sheet name)
For Each colCell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).SpecialCells(XlCellType.xlCellTypeConstants) '<--| iterate over its row 1 non blank cells
For Each rowCell In .Range(colCell.Offset(1), colCell.End(xlDown)) '<--| iterate over current column rows from row 2 down to last contiguous non empty one
wsOutput.Cells(outputRow, 1) = colCell.Value '<--| write ID in column 1 of current output row
wsOutput.Cells(outputRow, 2).Resize(, 3) = Split(rowCell.Value, "\") '<--| write other info from column 2 rightwards of current output row
outputRow = outputRow + 1 '<--| update output row
Next rowCell
Next colCell
End With
End Sub
should you deal with input sheet non contiguous data below any ID (blank cells) or ID with no data below, there would be needed a few changes