I'm having trouble combing MULTIPLE sheets (can be more than 2 sheets) in one.
Basically I have sheets with same column what I want is to combine them.
Example: This is just a scenario but can we have a dynamic code for more than 2 sheets, the Unique ID can be shuffle. But basically this is what I'm trying to achieve (output), combining the data on different sheets in one.
I tried to use the ADO and make query for UNION and INNER JOIN (because I think it will work) but no luck.
Hope anyone can help me.
Try this.
Sub test()
Dim vDB, Temp
Dim Ws(1 To 3) As Worksheet
Dim i As Long, j As Integer
Set Ws(1) = Sheets("Sheet1")
Set Ws(2) = Sheets("Sheet2")
Set Ws(3) = Sheets("Output")
vDB = Ws(1).Range("a1").CurrentRegion
Temp = Ws(2).Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
For j = 2 To UBound(vDB, 2)
If Temp(i, j) <> "" Then
vDB(i, j) = Temp(i, j)
End If
Next j
Next i
Ws(3).Range("a1").Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
End Sub
Sub SheetCode()
For Each sh In Sheets
If sh.Name <> Name Then
For Each cl In sh.Range("B2:D4")
If cl.Value <> "" Then Range(cl.Address).Value = cl.Value
Next
End If
Next
End Sub
This code assumes the tables are exactly identical in all sheets i.e. Headers & Unique IDs are in the same sequence.
Paste the code in Sheet where you want the data to be collected.
Related
I am pretty new to macros. Just need to do this small task at work.
Overview: I am running two different recipes/programs to generate data.
Every alternate row is a reading generated from different recipe. I want to compare the last two rows in the same sheet. If the values have a standard deviation of more than 0.5, I need to report or change the colors of the cells. How do I do that?
I wrote the following but it did not work for me:
Sub checkit()
Row1length = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Row1length
If Worksheets("Sheet1").Cells(7, i).Value <> Worksheets("Sheet1").Cells(8, i) Then
Match = False
Exit For
End If
Next
If Match = True Then
Debug.Print "match"
Else
Debug.Print "not match"
End If
End Sub
This code will loop through all the rows in the sheet and compare the first with the second, marking cells which have different values.
Sub CheckIt()
Const FirstDataRow As Long = 2 ' change as required
Dim Rl As Long, Cl As Long
Dim R As Long, C As Long
With Worksheets("Sheet1") ' change the sheet name
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Cl = .Cells(FirstDataRow, .Columns.Count).End(xlToLeft).Column
For R = FirstDataRow To Rl Step 2
For C = 1 To Cl
If (.Cells(R, C).Value) <> (Cells(R + 1, C).Value) Then
Range(.Cells(R, C), Cells(R + 1, C)).Interior.Color = vbYellow
End If
Next C
Next R
End With
End Sub
I am really stuck on a code for this form.
I want to create a command button that will allow the user to simplify the report and combine all like items and remove the duplicates. This will be used a Purchase request. I've attached a photo of the form here ->
Form
I need the button to find duplicates in column C and sum the totals from column F and then remove duplicates leaving the original behind with a grand total in the QTY menu. Is that possible and still keep it on the same sheet or would it be better to have it duplicate to a new sheet?
If the key is column C, this macro should do what you want, attach it to the button. To make it changeable easily for the key column, I defined the key as a constant and set it to 3 for now (col C):
Sub ProcessForm()
Dim wholeRange As Range, i As Long, ar
Const key As Long = 3 ' <-- column C is key. Set to 1 if col A
With Worksheets("Order")
Set wholeRange = .Range("A5:G" & .Cells(.Rows.Count, key).End(xlUp).row)
End With
With wholeRange
ar = .Columns(key).value
For i = 1 To UBound(ar)
ar(i, 1) = WorksheetFunction.SumIfs(.Columns(6), .Columns(key), ar(i, 1))
Next
.Columns(6).value = ar
.RemoveDuplicates key
End With
End Sub
Sub main()
Dim cell As Range
With Worksheets("Order")
With .Range("C5", .Cells(.Rows.Count, 3).End(xlUp))
For Each cell in .Cells
cell.Offset(,3).Value = WorksheetFunction.SumIf(.Cells, cell, .Offset(,3))
Next
.Offset(, -2).Resize(, 7).RemoveDuplicates Columns:=Array(3), Header:=xlNo
End With
End With
End Sub
Without seeing your code its difficult to say what your stuck on but here is quick example on How to search duplicates and sum the value
I'm using WorksheetFunction.Match Method (Excel)
Option Explicit
Sub Example()
' // Declare Variables
Dim DupRow As Variant
Dim i As Long
Dim LastRow As Long
Dim Sht As Worksheet
Set Sht = ThisWorkbook.Sheets("Sheet1")
With Sht
LastRow = .Cells(Rows.Count, "C").End(xlUp).Row
For i = LastRow To 2 Step -1
' // Columns 3 (C) DupRow
DupRow = Application.Match(Cells(i, 3).Value, Range(Cells(1, 3), Cells(i - 1, 3)), 0)
If Not IsError(DupRow) Then
' // Columns 6 (F) sum Match
Cells(i, 6).Value = Cells(i, 6).Value + Cells(DupRow, 6).Value
Rows(DupRow).Delete ' Delete DupRow
End If
Next i
End With
End Sub
I have data in about 50 sheets and structure for all of them are same. Please find data structure in an example below, in column May will be data and in next column letter for example "B" or "AB". I want to merge those two columns in one, so my data shold looks like 236AB. My code should work for all columns in sheets, because in some sheets I have 5 columns and in another 25. Anybody can help me with this one? Thank so much!
I have attach code for your requirement, It will automatically search for May and June keyword and will perform concatenation for that particular columns alone.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Ws As Worksheet
Dim monthss(12) As String
monthss(1) = "May"
monthss(2) = "June"
monthss(3) = "August"
For Each Ws In wb.Worksheets
For j = 1 To 3
With Ws.UsedRange
Set c = .Find(monthss(j), LookIn:=xlValues)
If Not c Is Nothing Then
firstrow = c.Row
firstcol = c.Column
End If
End With
Set c = Nothing
lastrow = Ws.Cells(Ws.Rows.Count, firstcol).End(xlUp).Row
' For May Sheet
If firstrow > 0 Then
For i = firstrow + 1 To lastrow
Ws.Cells(i, firstcol).Value = Ws.Cells(i, firstcol).Value & Ws.Cells(i, firstcol + 1).Value
Next
firstrow = 0
End If
' for June Sheet
Next j
Next Ws
End Sub
Not 100% sure what your end goal is but could you not add a new column on the left and make it's formula be CONCATENATE(A1:E1) and make it go as far down the sheet as you need it?
Then if you need to afterwards you could copy paste values that column and delete the others.
All fairly quick to do even if recording in excel.
Do you want to give that a go and post back if you get stuck?
Here is a Function that merges 2 Columns together:
Function mergeColumns(mergeColumn As Integer)
Dim i As Integer
'Adjust startvalue(1)
For i = 1 To ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row Step 1
'Combine mergeColumn and Column next to it
Cells(i, mergeColumn).Value = Cells(i, mergeColumn).Value & Cells(i, mergeColumn + 1).Value
'Clear the Content of the Cell next to Mergecolumn
Cells(i, mergeColumn + 1).Value = ""
Next i
End Function
Lets say you want to merge column A and B, the call would be mergeColumns 1
Now work out a routine to find the right columns to merge.
I'm brand new to VBA for excel (like a few hours ago new) and not really a programmer, so bear with me.
I have an excel data set, all in one column (column A) that is structured like this:
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
Data
That is, the data blocks are separated by blank rows, but not at regular intervals. I'm trying to write a macro that will go through the file and Group (the specific excel command) these blocks of data together. So far I have this:
Set firstCell = Worksheets("627").Range("A1")
Set currentCell = Worksheets("627").Range("A1")
Do While Not IsEmpty(firstCell)
Set firstCell = currentCell
Do While Not IsEmpty(currentCell)
Set nextCell = currentCell.Offset(1, 0)
If IsEmpty(nextCell) Then
Range("firstCell:currentCell").Select
Selection.Rows.Group
Set firstCell = nextCell.Offset(1, 0)
Else
Set currentCell = nextCell
End If
Loop
Loop
I'm sort of stuck, having particular trouble with the logic of moving to the next block of data and initiating.
Any help would be appreciated!
How about something like this:
Option Explicit
Public Sub tmpTest()
Dim i As Long
Dim lngLastRow As Long
With ThisWorkbook.Worksheets(1)
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lngLastRow To 1 Step -1
If .Cells(i, 1).Value2 = vbNullString Then
.Range(.Cells(i + 1, 1), .Cells(lngLastRow, 1)).EntireRow.Group
lngLastRow = i - 1
End If
Next i
.Range(.Cells(1, 1), .Cells(lngLastRow, 1)).EntireRow.Group
End With
End Sub
Here ya are. You just need to pull addresses in your range instead of trying to refer to the object. You also need to reset both current and first cell in your if statement.
Sub test()
Set firstCell = Worksheets("test2").Range("A1")
Set currentcell = Worksheets("test2").Range("A1")
Do While Not IsEmpty(firstCell)
Set firstCell = currentcell
Do While Not IsEmpty(currentcell)
Set nextcell = currentcell.Offset(1, 0)
If IsEmpty(nextcell) Then
Range(firstCell.Address, currentcell.Address).Select
Selection.Rows.group
Set currentcell = nextcell.Offset(1, 0)
Set firstCell = nextcell.Offset(1, 0)
Else
Set currentcell = nextcell
End If
Loop
Loop
End Sub
First of all, your code goes wrong when it says
Range("firstCell:currentCell").Select
You are trying to select the range named "firstCell:currentCell" instead of
selecting range from first Cell to currentCell
You should change it to
.Range(firstCell,currentCell).select
Try using below code and see if it does what you want it to do
Dim GROUP_LAST_CELL As Range
With Worksheets("627")
LAST_ROW = .Range("A" & Rows.Count).End(xlUp).Row
I = 1
While I <= LAST_ROW
Set GROUP_LAST_CELL = .Cells(I, 1).End(xlDown)
.Range(.Cells(I, 1), GROUP_LAST_CELL).Rows.Group
I = GROUP_LAST_CELL.Row + 2
Wend
End With
According to what i understood from the question, i think what you want to do is to loop across all the elements in a particular column, skipping all the blanks.
You can do so by
Calculating the lastrow of the column
Looping across from the first row count to the calculated lastRow count
Applying a condition within the loop to only print the non-empty cells
Code Block
Sub test()
Dim j As Long, lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For j = 1 To lastRow
If Cells(j, "A").Value <> "" Then
MsgBox (Cells(j, "A").Value)
End If
Next j
End Sub
I Hope this helped!
I have two workbooks , one is a active list(database) and the other is a project tracker(dashboard).
Both workbooks have a project ID.
I want that the workbook and active list should have a loop to match the exact project IDs.
If the project ID is found in the active list, it would retrieve information from that row and overwrite the existing row in the project tracker,which contains that project ID.
This is an example of the code which i have done, I did something relevant but it does not seem to work :
Sub AAA()
'If Workbooks("Source.xlsm").Sheets("Sheet2").Range("A2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("A2").Value Then
'Workbooks("Source.xlsm").Sheets("Sheet2").Range("B2").Value = Workbooks("Target.xlsm").Sheets("Sheet1").Range("C2").Value
Dim a As Long
Dim lastrow As Long
Dim lastcol As Long
Dim source As Worksheet
Dim target As Worksheet
Set target = Workbooks("Target.xlsm").Sheets("Sheet1")
Set source = Workbooks("Source.xlsm").Sheets("Sheet2")
lastrow = source.Range("A" & target.Rows.Count).End(xlUp).Row
lastcol = target.Cells(2, target.Columns.Count).Column
target.Activate
For a = 2 To 50
If source.Range("A" & a).Value = target.Range("A" & a).Value Then
target.Range("C" & a).Select
Range(ActiveCell, ActiveCell.Offset(0)).Copy
source.Range("B" & a).PasteSpecial
End If
Next a
End Sub
You are misunderstanding how you use the Range object. This .Range("A").Value does not work, you need to include a row number as well, such as .Range("A1").Value.
Your logic assumes that both lists are in exactly the same order. Using the Range.Find method gets round that problem.
Sub AAA()
Dim source As Worksheet
Dim target As Worksheet
Dim cell As Range
Dim cellFound As Range
Set target = Workbooks("Target.xlsm").Sheets("Sheet1")
Set source = Workbooks("Source.xlsm").Sheets("Sheet2")
For Each cell In target.Range("A2:A50")
' Try to find this value in the source sheet
Set cellFound = source.Range("A:A").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not cellFound Is Nothing Then
' A matching value was found
' So copy the cell 2 columns across to the cell adjacent to matching value
' Do a "normal" copy & paste
cell.Offset(ColumnOffset:=2).Copy cellFound.Offset(ColumnOffset:=1)
' Or do a copy & paste special values
'cell.Offset(ColumnOffset:=2).Copy
'cellFound.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues
Else
' The value in this cell does not exist in the source
' Should anything be done?
End If
Next
End Sub
Are you aware that you are using different sheets for source and for target?
target.Activate
For a = 2 To 50
If source.Range("A" & a).Value = target.Range("A" & a).Value Then
target.Range("C" & a).EntireRow.Select
Selection.Copy
source.Range("B" & a).PasteSpecial
End If
Next a
Not sure what volume of data you're going to be working with, but you could also use arrays to achieve what you're after.
Option Explicit
Sub AAA()
Dim i As Long, j As Long, k As Integer
Dim source As Worksheet, target As Worksheet
Dim arrTarget() As Variant, arrSource() As Variant
Dim lrowSrc As Long, lcolSrc As Long, lrowTrgt As Long, lcolTrgt As Long
Set target = Workbooks("Book4.xlsb").Sheets("Sheet1")
Set source = Workbooks("Book3.xlsb").Sheets("Sheet1")
lrowSrc = source.Cells(target.Rows.Count, 1).End(xlUp).Row
lcolSrc = source.Cells(2, source.Columns.Count).End(xlToLeft).Column
lrowTrgt = target.Cells(target.Rows.Count, 1).End(xlUp).Row
lcolTrgt = target.Cells(2, target.Columns.Count).End(xlToLeft).Column
target.Activate
arrTarget = target.Range(Cells(2, 1), Cells(lrowTrgt, lcolSrc))
source.Activate
arrSource = source.Range(Cells(2, 1), Cells(lrowSrc, lcolSrc))
target.Activate
For i = LBound(arrTarget, 1) To UBound(arrTarget, 1)
For j = LBound(arrSource, 1) To UBound(arrSource, 1)
If arrTarget(i, 1) = arrSource(j, 1) Then
For k = LBound(arrSource, 2) To UBound(arrSource, 2)
arrTarget(i, k) = arrSource(j, k)
Next k
Exit For
End If
Next j
Next i
target.Range("A2").Resize(UBound(arrTarget, 1), UBound(arrTarget, 2)).Value = arrTarget
End Sub
Working on 12,000 rows of data in the Target workbook and 25,000 in the Source workbook, with 6,000 matches, the code took 9.91 seconds to run.