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
Related
I had the task to extract the table and match the abbreviations in the "Number" column with the list of companies. For example: copy all the rows where "KP00000221" is written in the Number column and put it in a separate file. The same should be done for "VT", "AK" and so on.
I wrote the code, but I don't have an understanding of how I can create a collection of matches for each abbreviation (there are only five of them). Next, need write collection of rows to different files.
Sub testProjectMl()
Sheets(ActiveSheet.Name).Range("K:K,M:M,N:N").EntireColumn.Delete 'Delete Columns
Set regexPatternOne = New RegExp
Dim theMatches As Object
Dim Match As Object
regexPatternOne.Pattern = "KP\d+|KS\d+|VT\d+|PP\d+|AK\d+" 'Pattern for Search Companies Matches in Range
regexPatternOne.Global = True
regexPatternOne.IgnoreCase = True
Dim CopyRng As Range 'Declarate New Range
With Sheets(ActiveSheet.Name)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'because I do not know how many lines there will be in the file
For i = 8 To LastRow
'some code
Next i
End With
End Sub
As a result, I need to create five different files with tables
KP_table -> Paste row with KP00000221
AK_table -> AK data and etc.
The task is complicated by the fact that there can be a lot of such data with abbreviations in the table, and all the row data needs to be filtered and entered into a separate file, where there will be information only on the company. That is, all these abbreviations: KP, KS, AK are different companies.
The problem is that I don't understand how to logically implement the idea: I created a regex pattern, now I need to create a collection (for example, KP_data) and add all the matches for KPXXXXXXXX and so on there.
Any suggestions? Thanks.
Please, test the next code. It uses a dictionary to keep a Union range of each case and drop each its item in the next sheet, with an empty row between them. Copying a Union range instead of each involved row, is much faster:
Sub testProjectMl()
Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
Dim i As Long, arrA, dict As Object
Set sh = ActiveSheet
lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
firstRow = 7 'the row where the headers exist
Set shDest = sh.Next
arrA = sh.Range("A" & firstRow & ":A" & lastRow).value 'place the range in an array for faster iteration
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arrA) 'iterate between the array rows
If Not dict.Exists(arrA(i, 1)) Then 'if not a key exists:
'create it composed by the header and the current row
dict.Add arrA(i, 1), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
Else
'make a Union between the existing item and the new row:
Set dict(arrA(i, 1)) = Union(dict(arrA(i, 1)), _
sh.Range(sh.cells(i + firstRow - 1, "A"), sh.cells(i + firstRow - 1, "K")))
End If
Next i
'drop the dictionary items content (in the next sheet) with an empty row between each group:
For i = 0 To dict.count - 1
lastERowDest = shDest.Range("A" & shDest.rows.count).End(xlUp).row + 1
If lastERowDest = 2 Then lastERowDest = 1
dict.items()(i).Copy shDest.Range("A" & lastERowDest + 1)
Next i
End Sub
Option Explicit
Sub test()
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim MyKey As Object
Dim i As Long
Dim LR As Long
Dim LR2 As Long
Dim WKdata As Worksheet
Set WKdata = ThisWorkbook.Worksheets("data") 'Worksheet with source data
With WKdata
LR = .Range("A" & .Rows.Count).End(xlUp).Row 'last row with data
End With
For i = 8 To LR Step 1 '8 is first row with data, headers are in row 7
If Dict.Exists(WKdata.Range("A" & i).Value) = False Then
'This number is first time found. Create file and add it
Workbooks.Add 'now this is the activeworkbook
Dict.Add WKdata.Range("A" & i).Value, ActiveWorkbook.ActiveSheet 'create a reference for this file
WKdata.Range("A7:K7").Copy Dict(WKdata.Range("A" & i).Value).Range("A1:K1") 'headers from row 7
WKdata.Range("A" & i & ":K" & i).Copy Dict(WKdata.Range("A" & i).Value).Range("A2:K2") 'row 2 is always first row of data
Else
'this number has been found before. Add data to existing file
With Dict(WKdata.Range("A" & i).Value)
LR2 = .Range("A" & .Rows.Count).End(xlUp).Row + 1 '1 row below last row with data
End With
WKdata.Range("A" & i & ":K" & i).Copy Dict(WKdata.Range("A" & i).Value).Range("A" & LR2 & ":K" & LR2)
End If
Next i
Set Dict = Nothing
Set WKdata = Nothing
End Sub
The code loops trough a dictionary with references to each new file created.
My source data is a worksheet named Data
After executing code, I get new files for each key (grouped rows by keys)
As you can see, I got 3 different unique keys and each one to their file with all its data.
You only need to adapt the code to save each file where you want, following your pattern. Probably you'll need to loop trough each key of the dictionary, check number value and then save the file properly
About dictionaries in VBA, please check this source:
Excel VBA Dictionary – A Complete
Guide
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
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 have two sheets, the master sheet that is where input data, and the slave sheet where I store the data. In the master sheet when I put the data in table I want to copy it over and send it to the slave sheet in the correct table format. In order to accomplish this I created a variable that will find the last row in the slave sheet as the table will be growing. The button I made copies the data from the table (this part works) and is supposed to be copied over to the new range.
Sub button_click1()
Dim lRow As Long
Dim lCol As Long
Dim ERow As Long
Dim c As Range
Dim Mws As Worksheet
Dim DSws As Worksheet
Set Mws = Sheets("Master")
Set DSws = Sheets("DayShift")
'Find the last non-blank cell in column A(1)
lRow = DSws.Cells(Rows.Count, 1).End(xlUp).Row
'Find the last non-blank cell in row 1
lCol = DSws.Cells(1, Columns.Count).End(xlToLeft).Column
'Create range'
lRow = lRow + 1
ERow = lRow + 3
'Message Box'
MsgBox "Last Row: " & lRow & vbNewLine & _
"Last Column: " & lCol & vbNewLine & _
"Range: " & lRow & ":" & ERow
'Copy data from table'
Mws.Range("A2:I5").Copy DSws.Range("AlRow:IERow")
'Inserting 3 Rows from 3
'ActiveSheet.Rows("lRow:ERow").EntireRow.Insert'
End Sub
The error I get is in the EntireRow.insert function. I can't find anything online on how to create my own dynamic range. Thanks in advance.
There is no need to reshape the target area of a copy & paste. You only need the top-left cell of a destination.
...
Mws.Range("A2:I5").Copy DSws.Range("A" & lRow)
However, if you are direct transferring values by way of arrays (i.e. without the clipboard), you will need to reshape the target area to match the dimensions of the array.
dim arr as variant
arr = Mws.Range("A2:I5").value
DSws.Range("A" & lRow).resize(ubound(arr, 1), ubound(arr, 2)) = arr
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