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
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've been trying to find a solution for that problem but nothing came up.
Here is the problem I've got. I would like to copy a variable data range from a sheet called ("Amounts") starting in range "C3" to an other sheet called ("Pasted Amounts") in range F2 as many time as columns, in sheets "Amounts" are starting with the following value " Amounts in USD".
I've been coding something but it doesn't work... I put a counter in a cell to count how many time there are columns starting with the value " Amounts in USD" in order to pick the value appearing in that cell and repeat the paste process. But I've been complicated the code I guess...
Here is my code;
Dim cel2 As Range
Dim counter as Integer
With Sheets("Amounts")
Worksheets("Amounts").Activate
For Each cel2 In Range("A2", Range("A2").End(xlToRight))
If cel2.Value Like "Amount in USD*" Then
counter = counter + 1
Range("U4").Value = counter
End If
With Worksheets("Pasted Amounts").Activate
'~Here is bellow the column named " clients name" I want to paste in "Pasted amounts" sheet (by coping it in the sheet "Amounts"
worksheets("Amounts").Range("C3",range("C3").end(xldown).Select
'~ Paste the range copied in sheet " Pasted Amount" as many time the counter value is
.Copy Range("F2").Resize(.Count * counter)
End With
Next cel2
End With
End sub
Once again, I'd appreciate so much your help...
Mido88
Sub test()
Dim LastColumn As Long, LastRow As Long, counter as Long
With Sheets("Amounts")
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
counter = WorksheetFunction.CountIf(.Range("A1", .Cells(1, LastColumn)), "Amount in USD*")
.Range("C3:C" & LastRow).Copy _
Worksheets("Pasted Amounts").Range("F2").Resize(.Range("C3:C" & LastRow).Count * counter)
End With
End Sub
Or as a silly long one line of code:
Sub test()
Sheets("Amounts").Range("C3:C" & Sheets("Amounts").Cells(Sheets("Amounts").Rows.Count, "C").End(xlUp).Row).Copy Worksheets("Pasted Amounts").Range("F2").Resize(Sheets("Amounts").Range("C3:C" & Sheets("Amounts").Cells(Sheets("Amounts").Rows.Count, "C").End(xlUp).Row).Count * WorksheetFunction.CountIf(Sheets("Amounts").Range("A1", Sheets("Amounts").Cells(1, Sheets("Amounts").Cells(1, Sheets("Amounts").Columns.Count).End(xlToLeft).Column)), "Amount in USD*"))
End Sub
Alright I found the solution!
Thank you again Siddharth and Christofer, your answers helped me a lot to think further...
Here is the solution that worked really well! I used the answer in the previous post I made here:link and added a single line code to paste as many time the range of datas as" Amounts in USD " was found in the previous sheet.
Sorry again for those misunderstandings. I hope that my answer would help you and the other users in need!
Here it is;
Sub Sample()
Dim wsInput As Worksheet
Dim wsOutput As Worksheet
Dim lRowInput As Long
Dim lRowOutput As Long
Dim lCol As Long
Dim i As Long
Dim Col As String
'~~> Set your sheets here
Set wsInput = Sheets("Amounts")
Set wsOutput = Sheets("Pasted Amounts")
With wsInput
'~~> Find last column in Row 2
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
'~~> Loop through columns
For i = 1 To lCol
'~~> Check for your criteria
If .Cells(2, i).Value2 Like "Amount in functional currency*" Then
'~~> Get column name
Col = Split(.Cells(, i).Address, "$")(1)
'~~> Get the last row in that column
lRowInput = .Range(Col & .Rows.Count).End(xlUp).Row
'~~> Find the next row to write to
If lRowOutput = 0 Then
lRowOutput = 2
Else
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
End If
'~~> Copy the datas ( for each column where Amounts in USD was found)
.Range(Col & "3:" & Col & lRowInput).Copy _
wsOutput.Range("A" & lRowOutput)
~~> SOLUTION BELLOW-Copy the variable data range ("C3")
Worksheets("Amounts").Activate
.Range("C3", Range("C3").End(xlDown)).Copy wsOutput.Range("F" & lRowOutput)
End If
Next i
End With
End Sub
Mido
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'm looking to create a macro that will display the Sum from a set column of each of multiple sheets. I need the total of column "K" to be shown 1 row from the last entry of a variable number of entries. It is a requirment that this is in VBA as it needs to run with a number of other functions.
I've tried the below code but it does not give the expected result and seems to be drawing data from other sheets.
Sub SumWorksheets()
Dim LastRow As Long
Dim ws As Worksheet
For Each ws In Worksheets
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("K" & LastRow + 1) = Application.WorksheetFunction.Sum(Range("K2:K" & ws.Rows.Count))
Next
End Sub
I want the Total of all numbers in Column "K" to display 2 rows below the last number in Row "K"
Declared and fully use ws and LastRow variables. Not using can cause code to pull values from another worksheet. Per comment from #LoveCoding, using a different column as the LastRow can overwrite a cell in Col K. You should have used the LastRow variable, in the Sum function.
Dim ws As Worksheet, LastRow As Long
For Each ws In ThisWorkbook.Worksheets
LastRow = ws.Range("K" & ws.Rows.Count).End(xlUp).Row
ws.Range("K" & LastRow + 1) = Application.WorksheetFunction.Sum(ws.Range("K2:K" & LastRow))
Next
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