I have an excel sheet of some 7k rows of data, I need to segregate that data into three different sheets based on a column( group name).
So , I need to segregate the data based on the group name (there are 3 groups) into three different sheets.
Please let me know regarding this...
Thanks in advance...
Kar
You can try something like this, put it in a macro and run on demand
Sub Macro1()
Dim rowCounter As Integer
Dim usedRange As Range
Dim sourceSheet As Worksheet, dest1 As Worksheet, dest2 As Worksheet, dest3 As Worksheet
Dim dest1Row As Integer, dest2Row As Integer, dest3Row As Integer
dest1Row = 1
dest2Row = 1
dest3Row = 1
Set sourceSheet = Sheets("Sheet1")
Set dest1 = Sheets("Sheet2")
Set dest2 = Sheets("Sheet3")
Set dest3 = Sheets("Sheet4")
Set usedRange = sourceSheet.usedRange
For rowCounter = 1 To usedRange.Rows.Count
If (usedRange(rowCounter, 1) = 1) Then
usedRange.Range(Cells(rowCounter, 1), Cells(rowCounter, usedRange.Columns.Count)).Copy dest1.Range("A" & dest1Row)
dest1Row = dest1Row + 1
ElseIf (usedRange(rowCounter, 1) = 2) Then
usedRange.Range(Cells(rowCounter, 1), Cells(rowCounter, usedRange.Columns.Count)).Copy dest2.Range("A" & dest2Row)
dest2Row = dest2Row + 1
ElseIf (usedRange(rowCounter, 1) = 3) Then
usedRange.Range(Cells(rowCounter, 1), Cells(rowCounter, usedRange.Columns.Count)).Copy dest3.Range("A" & dest3Row)
dest3Row = dest3Row + 1
End If
Next rowCounter
End Sub
Related
I'm using this code to transfer invoice data in one sheet to invoice history in another sheet and it is working as intended. However, I cannot figure out how to transfer said data to the invoice history sheet without ruining the formatting of the table. The picture below shows what happens when the data is entered manually versus when the code is used (last three rows).
Dim xNew As Worksheet 'New Invoice Sheet
Dim xInvoices As Worksheet 'Invoice History Sheet
Dim iCurrentRow As Integer
Set xNew = ThisWorkbook.Sheets("New_Invoice")
Set xInvoices = ThisWorkbook.Sheets("Invoices")
iCurrentRow = xInvoices.Cells(xInvoices.Rows.Count, "B").End(xlUp).Row + 1
With xInvoices
.Cells(iCurrentRow, 2) = xNew.Range("F5")
.Cells(iCurrentRow, 3) = xNew.Range("B9")
.Cells(iCurrentRow, 4) = xNew.Range("Total")
.Cells(iCurrentRow, 5) = "Not Paid"
.Cells(iCurrentRow, 6) = "Outright"
.Cells(iCurrentRow, 7) = Date + 1
End With
You did not answered the clarification question, but if there is a real ListObject in the sheet you try pasting below its last row, please try the next code:
Sub testLstRTable()
Dim xNew As Worksheet, xInvoices As Worksheet, firstR As Long, lastR As Long, tb As ListObject
Set xNew = ThisWorkbook.Sheets("New_Invoice")
Set xInvoices = ThisWorkbook.Sheets("Invoices")
Set tb = xInvoices.ListObjects("YourTable") 'use here your real table name!!!
firstR = tb.HeaderRowRange.row 'for the case when the table header row is not the first...
lastR = tb.ListRows.count + firstR
xInvoices.Range(xInvoices.cells(lastR + 1, 2), xInvoices.cells(lastR + 1, 7)).value = _
Array(xNew.Range("F5").value, xNew.Range("B9").value, xNew.Range("Total").value, "Not Paid", "Outright", Date + 1)
End Sub
Please, pay attention to changing the Table name, using the one existing in the involved sheet.
But if you name a simple formatted range as a table, please use the next code variant:
Sub testKeepFormat()
Dim xNew As Worksheet, xInvoices As Worksheet, lastR As Long
Set xNew = ThisWorkbook.Sheets("New_Invoice")
Set xInvoices = ThisWorkbook.Sheets("Invoices")
lastR = xInvoices.Range("B" & xNew.rows.count).End(xlUp).row
With xInvoices.Range(xInvoices.cells(lastR + 1, 2), xInvoices.cells(lastR + 1, 7))
.value = Array(xNew.Range("F5").value, xNew.Range("B9").value, xNew.Range("Total").value, "Not Paid", "Outright", Date + 1)
.Interior.Color = .Offset(-2).Interior.Color
.cells(1, 2).HorizontalAlignment = .Offset(-2).cells(1, 2).HorizontalAlignment
End With
End Sub
Copy Row Data Using Insert
This will use the formatting of the last row.
Option Explicit
Sub RecordNewInvoice()
Const sName As String = "NewInvoice"
Const dName As String = "Invoices"
Const dCol As String = "B"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim RowData As Variant: RowData = GetRowData(sws)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, dCol).End(xlUp)
dCell.Offset(1).EntireRow.Insert
dCell.Offset(1).Resize(, UBound(RowData)).Value = RowData
End Sub
Function GetRowData( _
sws As Worksheet) _
As Variant
Dim RowData(1 To 6) As Variant
RowData(1) = sws.Range("F5").Value
RowData(2) = sws.Range("B9").Value
RowData(3) = sws.Range("Total").Value
RowData(4) = "Not Paid"
RowData(5) = "Outright"
RowData(6) = Date + 1
GetRowData = RowData
End Function
I need to contactinate data of two columns from two different worksheets using vba macro.
Ex- in an excel sheet there are two tabs/worksheets sheet1 and sheet2. sheet1 is having column firstname & middlename, sheet2 is having column last name. I want to concat all first,middle & last name .
i am able to concat column which are present in same worksheet but not the column from different worksheets. Kindly suggest.
Thanks.
As you wanted a VBA solution, I've put something together for you. It checks if the number of rows in columns A in the two sheets are the same, loads the data from columns A/B in the first sheet and column A in the second sheet into an array, and then loops these arrays, concatenating then with spaces between using Trim to cater for missing values and writing this to the column B of the second sheet:
Sub sConcatenate()
Dim wsFName As Worksheet
Dim wsLName As Worksheet
Dim wsOutput As Worksheet
Dim lngLastRow As Long
Dim lngLoop1 As Long
Dim aFName() As Variant
Dim aMName() As Variant
Dim aLName() As Variant
Set wsFName = ThisWorkbook.Worksheets("FName")
Set wsLName = ThisWorkbook.Worksheets("LName")
Set wsOutput = ThisWorkbook.Worksheets("LName")
lngLastRow = wsFName.Cells(wsFName.Rows.Count, "A").End(xlUp).Row
If lngLastRow = wsOutput.Cells(wsOutput.Rows.Count, "A").End(xlUp).Row Then
aFName = wsFName.Range("A1:A" & lngLastRow).Value
aMName = wsFName.Range("B1:B" & lngLastRow).Value
aLName = wsLName.Range("A1:A" & lngLastRow).Value
For lngLoop1 = LBound(aFName, 1) To UBound(aFName, 1)
wsOutput.Cells(lngLoop1, 2) = Trim(Trim(aFName(lngLoop1, 1) & " " & aMName(lngLoop1, 1)) & " " & aLName(lngLoop1, 1))
Next lngLoop1
End If
Set wsFName = Nothing
Set wsLName = Nothing
Set wsOutput = Nothing
End Sub
Regards,
Why don't you just use the CONCATENATE function? Open both workbooks and in the destination cell write the CONCATENATE function with the directions.
=CONCATENATE(Cell from Workbook 1," ",Cell from Workbook 2)
You didn't mention the details of your use case. But if you want something programatic, the code below shows how you can reference different workbooks and worksheets. You can a for loop and modify it for your use case.
Sub conc()
Dim destination_Wb as Workbook, wb1 As Workbook, wb2 As Workbook
Dim destination_Ws as Worksheet, ws1 As Worksheet, ws2 As Worksheet
Set destination_Wb = Workbooks(“Destination Workbook.xlsm”)
...
...
Set destination_Ws = destination_Wb.Sheets("Sheet1")
...
...
destination_Ws.Cells(1, 1).Value = ws1.Cells(1, 1).Value + " " + ws2.Cells(1, 1).Value
End sub
Concatenate Columns
Adjust the values in the constants section.
The Code
Option Explicit
Sub ConcatNames()
Const Source As String = "Sheet1"
Const Target As String = "Sheet2"
Const NameColumn As Long = 1
Const MiddleNameColumn As Long = 2
Const LastNameColumn As Long = 1
Const FullNameColumn As Long = 2
Const FirstRow As Long = 2
Dim rng As Range
Dim vName, vMiddle, vLast, vFull
Dim RowsCount As Long, i As Long
Dim CurrString As String
With ThisWorkbook.Worksheets(Source)
Set rng = .Columns(NameColumn).Find(What:="*", _
LookIn:=xlFormulas, SearchDirection:=xlPrevious)
Set rng = .Range(.Cells(FirstRow, NameColumn), rng)
vName = rng
RowsCount = rng.Rows.Count
Set rng = .Cells(FirstRow, MiddleNameColumn).Resize(RowsCount)
vMiddle = rng
End With
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, LastNameColumn).Resize(RowsCount)
vLast = rng
End With
ReDim vFull(1 To RowsCount, 1 To 1)
For i = 1 To RowsCount
GoSub BuildString
Next i
With ThisWorkbook.Worksheets(Target)
Set rng = .Cells(FirstRow, FullNameColumn).Resize(RowsCount)
rng = vFull
End With
Exit Sub
BuildString:
If vName(i, 1) = "" Then Return
CurrString = vName(i, 1)
If vMiddle(i, 1) <> "" Then CurrString = CurrString & " " & vMiddle(i, 1)
If vLast(i, 1) <> "" Then CurrString = CurrString & " " & vLast(i, 1)
vFull(i, 1) = WorksheetFunction.Trim(CurrString)
Return
End Sub
I want to write a code that uses two 1D arrays and based on the match with the value on the row, it should return the value in the 3rd array.
This is what I want to do:
In Sheet1, I have 3 columns with data on ID, Name, and Amount with a number of rows of uncertain size:
In Sheet2, I have already the columns with data on ID and Name but I don't have the data on Amount:
Therefore, I want to run the code that will match the arrays with ID and Name data in Sheet1 with ID and Name data in Sheet2 and then, return the respective Amount data to Sheet2 as it is in Sheet1.
This is the desired outcome in Sheet2 after running the code, i.e. the data in column Amount are returned based on the match with arrays on ID and Name in Sheet1:
This is my code that does not run as it should:
Sub ArrayMatch()
Dim r As Long
Dim d As Long
Dim w_output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Integer
Dim IntLastCol As Integer
Dim arrName() As Variant
Dim arrID() As Variant
Dim arrrAmoun() As Variant
d = 8
With ThisWorkbook
Set w1 = .Sheets("Sheet1")
Set w_output = .Sheets("Sheet2")
End With
'***********************************
'Assign arrays
With w1
intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
IntLastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
arrID = .Range(.Cells(4, 1), .Cells(intLastRow, 1))
arrName = .Range(.Cells(4, 3), .Cells(intLastRow, 2))
arrAmoun = .Range(.Cells(4, 4), .Cells(intLastRow, 3))
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
d = d + 1
If w_output.Cells(d, 1) = arrID(r, 1) Then
If w_output.Cells(d, 2) = arrName(r, 1) Then
w_output.Cells(d, 4) = arrAmoun(r, 1)
End If
End If
End If
Next r
End With
End Sub
My code does not return anything, I can assume that it is because I am comparing the arrays from sheet1 with rows in sheet 2 which is not comparative in the size, but I don't know how to do in another way.
I will appreciate any help.
Just modified your code to include an inner loop to check for ID and name in w_output sheet (it could also be done with Find). Tested with makeshift data. However there are other (more efficient) ways to achieve the same goal.
Sub ArrayMatch()
Dim r As Long
Dim d As Long
Dim w_output As Worksheet
Dim w1 As Worksheet
Dim intLastRow As Long ' Modified to long
Dim IntLastRow1 As Long ' Modified to long
Dim arrName() As Variant
Dim arrID() As Variant
Dim arrrAmoun() As Variant
'd = 8
With ThisWorkbook
Set w1 = .Sheets("Sheet1")
Set w_output = .Sheets("Sheet2")
End With
'***********************************
'Assign arrays
With w1
intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
IntLastRow1 = w_output.Cells(Rows.Count, 1).End(xlUp).Row
arrID = .Range(.Cells(4, 1), .Cells(intLastRow, 1))
arrName = .Range(.Cells(4, 3), .Cells(intLastRow, 3))
arrAmoun = .Range(.Cells(4, 4), .Cells(intLastRow, 4))
For r = 1 To UBound(arrID, 1)
If Len(arrID(r, 1)) > 0 Then
For d = 9 To IntLastRow1 ' Modified to for loop for w_output sheet
If w_output.Cells(d, 1) = arrID(r, 1) Then
If w_output.Cells(d, 2) = arrName(r, 1) Then
w_output.Cells(d, 4) = arrAmoun(r, 1)
Exit For ' added once found and amount put in place
End If
End If
Next
End If
Next r
End With
End Sub
All-
I'm very new to VBA and I really need help. I have a worksheet called Sheet 1 that looks like this (This is where the data will be copied from)
and another sheet (Sheet2) that looks like this (this is where the data will be copied to). Notice that the order is not the same as above
When a user types in a place such as "Paris" I want it to copy all corresponding values with "Paris" and it's associated rows. So the end result should look like this
Here is the code I have so far. Right now I can pull all the corresponding values based on the Users input, but I cannot for the life of me figure out how to get the associated rows. Please help! Any input will be highly appreciated.
Dim x As String
Dim K As Long
Dim ct As Variant
Dim r As Range
Dim w1 As Worksheet
Dim w2 As Worksheet
Set w1 = Sheets("Sheet1")
Set w2 = Sheets("Sheet2")
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
x = Application.InputBox("Please Enter Place")
w1.Activate
K = 3
For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)
ct = r.Value
If InStr(ct, x) > 0 And ct <> "" Then
r.Copy w2.Cells(K, 1)
K = K + 1
w2.Activate
End If
Next r
End Sub
Assign the entire range to an array for quicker looping, then once the array finds a match to your inputstring, rewrite the values to your 2nd sheet.
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()
set ws1 = thisworkbook.worksheets("Sheet1")
set ws2 = thisworkbook.worksheets("Sheet2")
With ws1
wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value
End With
Dim findStr As String
findStr = InputBox("Please Enter Place")
Dim i As Long, r as long
Application.ScreenUpdating = False
With ws2
.Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")
For i = LBound(wsArr) To UBound(wsArr)
If wsArr(i, 3) = findStr Then
r = LastRow(ws2) + 1
.Cells(r, 1) = wsArr(i, 3)
.Cells(r, 2) = wsArr(i, 1)
.Cells(r, 3) = wsArr(i, 2)
.Cells(r, 4) = wsArr(i, 4)
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long
With ws
LastRow = .Cells(.Rows.Count, col).End(xlUp).Row
End With
End Function
For even better performance, consider doing a COUNTIF() to get the count of the number of findStr occurances in your range - that way you can use this value to ReDim a new array in order to write the matches there, then write the array to Sheet2 all at once.
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True