I am trying to develop an index, but in order to make correct calculations and pivot tables, I need to merge some cells. Doing this manually would take a lot of time, therefore I am looking for a more efficient way. I assume a Macro might help me out here, yet I do not really know how to get started.
A bit of context on the datasheet: The info in cells E until AB was used to calculate the numbers in cells AC, AD, AE and AF. This information was hided as these cells do not need to be merged.
I am in the need of a macro that:
Merges the value in column A when the organization name is identical.
Merges the information in columns AC, AD, AE and AF when it refers to the same organization in column A.
Can somebody help me out? Thank you in advance for the help!!
https://i.stack.imgur.com/LShf3.png
This should be a result, but then accomplished with a macro so that it can be done efficiently for larger lists:https://i.stack.imgur.com/tm4RQ.png
Try this code:
Sub SubMerge()
'Declarations.
Dim RngName As Range
Dim RngFirstCat As Range
Dim DblTotalCat As Double
Dim DblCounter01 As Double
'Settings.
Set RngName = Range("A2")
Set RngFirstCat = Range("AC2")
DblTotalCat = 4
'Deactivating display alerts.
Application.DisplayAlerts = False
'Repeat until an empty cell is found.
Do Until RngName.Value = ""
'Repeat until a different value is found.
Do Until RngName.Offset(1, 0).Cells(RngName.Cells.Count, 1).Value <> RngName.Cells(1, 1).Value
'Increasing the size of RngName by 1 row.
Set RngName = RngName.Resize(RngName.Rows.Count + 1)
Loop
'Checking if RngName has more than 1 row.
If RngName.Rows.Count > 1 Then
'Setting RngFirstCat.
Set RngFirstCat = Cells(RngName.Row, RngFirstCat.Column).Resize(RngName.Rows.Count)
'Covering each category.
For DblCounter01 = DblTotalCat - 1 To 0 Step -1
'Merging the cells.
RngFirstCat.Offset(0, DblCounter01).Merge
Next
End If
'Setting RngName for the next value.
Set RngName = RngName.Cells(1, 1).Offset(RngName.Cells.Count)
Loop
'Deactivating display alerts.
Application.DisplayAlerts = True
End Sub
Related
The problem that I'm facing is concerning Excel. I'm trying to extract rows with multiple columns out of sheets based on certain criteria. I've found some solutions regarding this, but nothing is really what I'm looking for or I can't change it to make it work. I'll try to explain the issue more detailed below using an example.
Situation:
8 sheets (named Sh1 to Sh8) with a list of tasks
Each sheet represents a kind of task (personal, work, ...)
Each sheet has the same format
Data is located starting from row 4 and between column A to K
Below the data is a row with total calculations
The data includes text, numbers and blank cells
Column D is the status of the task (C for completed, I for in progress, N for not started)
Style of the sheets is completely done by using conditional formatting
I would like something that checks those 8 sheets and copies all entries (including the blank cells) that are a certain status, being either C, I or N, to a new sheet, called "Filtering". The filtering sheet will have headers as well and the data should start at row 7.
When I started this, I came up with a formula (based on this) that copies all the entries of one sheet. I could filter it by putting C, I or N in the cell D4 on the filtering sheet.
{
=IFERROR(
INDEX(
Sh1!A$4:A$19;SMALL(
IF(
Sh1!$D$4:$D19=Filtering!$D$4;
ROW(Sh1!A$4:A$19)-ROW(Sh1!A$4)+1
);
ROWS(Sh1!A$4:Sh1!A4)
)
);
"")
}
As I said before, the data includes blank cells, so I changed the formula to the following to make sure the blank cells didn't turn into 0's:
{
=IFERROR(
IF(
INDEX(SAME AS ABOVE)="";
"";
INDEX(SAME AS ABOVE);
);
"")
}
Although this worked, I could only perform this on one sheet, and not on all eight. I could solve this by starting Sh2 at a lower row in the filtering sheet and do this for all other sheets, but that's not really what I'd like to get. I would really like to get to a continuous list that sums up all the not started, completed or in progress by changing that one cell D4 on the filtering sheet.
That's where I would like your suggestions. If it's possible to do this without VBA, I'd prefer that, since I sometimes use it in the online web application and macro's don't work there. If VBA is the only solution, obviously that'd be okay too.
On a side note: I tried VBA based on a code that I found here. (please have patience with me, I never coded before this) but it seems really slow to process this. Every time I run the macro, it takes more than 15 seconds to calculate this, although there are only 200 tasks that I currently have. The following was for getting all the completed tasks. I could easily make the others by changing the C to I or N. There was another problem where the whole sheet was removed, including my headers, so I'd have to put a range on the clear.
Sub ExtractList()
Dim ws As Worksheet
Dim destinationWorksheet As Worksheet
Dim columnD As Range
Dim c As Range
Dim count As Long
Set destinationWorksheet = ActiveWorkbook.Worksheets("Filtering")
destinationWorksheet.Cells.ClearContents
count = 1
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Sh1" Or ws.Name = "Sh2" Or ws.Name = "Sh3" Or ws.Name
= "Sh4" Or ws.Name = "Sh5" Or ws.Name = "Sh6" Or ws.Name = "Sh7" Or
ws.Name = "Sh8" Then
Set columnD = ws.Range("D:D") 'columnD
For Each c In columnD
If WorksheetFunction.IsText(c.Value) Then
If InStr(c.Value, "C") > 0 Then
c.EntireRow.Copy
destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats
count = count + 1
End If
End If
Next c
End If
Next ws
End Sub
Thanks already for reading through this and I'm looking forward to your suggestions.
Cheers,
Bart
The reason your code is taking too long to run is because you are looping through the entire column. You need to delimit the range to work with.
This solution:
• Allows the user to determine the extraction criteria using cell D4 in “Filtering” worksheet (Target)
• Sets the data ranges for each worksheet [Sh1, Sh2, Sh3, Sh4, Sh5, Sh6, Sh7, Sh8] (Source)
• Uses AutoFilter to select the data required and
• Posts the resulting ranges from all worksheets in the “Filtering” worksheet
It assumes that:
• All worksheets involved have the same structure and headers
• Headers are located at A6:K6 for Target worksheet and A3:K3 for Source worksheets (change as required)
Sub ExtractList()
Dim wshTrg As Worksheet, wshSrc As Worksheet
Dim sCriteria As String
Dim rDta As Range
Dim rTmp As Range, rArea As Range, lRow As Long
Rem Set Worksheet Target
Set wshTrg = ThisWorkbook.Worksheets("Filtering") 'change as required
Rem Clear prior data 'Header at row 6 & data starts at row 7 - change as required
With wshTrg
Rem Sets Criteria from Cell [D4] in target worksheet
sCriteria = .Cells(4, 4).Value2
.Cells(7, 1).Value = "X" 'To set range incase there is only headers
.Range(.Cells(7, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents
End With
Rem Process each worksheet
lRow = 7
For Each wshSrc In ThisWorkbook.Worksheets
Select Case wshSrc.Name
Case "Sh1", "Sh2", "Sh3", "Sh4", "Sh5", "Sh6", "Sh7", "Sh8"
With wshSrc
Rem Clear AutoFilter
If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter
Rem Set Data Range
Set rDta = .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 11))
End With
With rDta
Rem Apply AutoFilter
.AutoFilter Field:=4, Criteria1:=sCriteria
Rem Set resulting range
Set rTmp = .Offset(1).Resize(-1 + .Rows.count).SpecialCells(xlCellTypeVisible)
Rem Clear Autofilter
.AutoFilter
End With
Rem Post Resulting range in target worksheet
For Each rArea In rTmp.Areas
With rArea
wshTrg.Cells(lRow, 1).Resize(.Rows.count, .Columns.count).Value = .Value2
lRow = lRow + .Rows.count
End With: Next: End Select: Next
End Sub
Suggest to read the following pages to gain a deeper understanding of the resources used:
Range Object (Excel), Range.Offset Property (Excel),
Range.SpecialCells Method (Excel),
Select Case Statement, Worksheet.AutoFilter Property (Excel),
Worksheet.AutoFilterMode Property (Excel), With Statement
I have an excel file like
Original File
I want to transform all the cells that filled with information into a single column. Like
To transform This
How to i do this ?
I searched in internet about that i found just only transform cells in a single row to a single cell. But i couldn't find anything like this. Can you help me about that
This is a bit of code I keep around for this kind of job. It assumes that the values in each row are contiguous, that is there are no blank cells inside the data set. It also assumes that you're on the sheet that contains the data when you trigger it, and that you want the data to be placed on a new worksheet.
Option Explicit
Sub Columnise()
Dim shtSource As Worksheet
Dim shtTarget As Worksheet
Dim rngRow As Range, rngCol As Range
Dim lCount As Long
Set shtSource = ActiveSheet 'Or specify a sheet using Sheets(<name>)
Set rngCol = Range("A1", Range("A" & Rows.Count).End(xlUp))
Set shtTarget = Sheets.Add 'Or specify a sheet using Sheets(<name>)
'Define starting row for the data
lCount = 1
'Loop through each row
For Each rngRow In rngCol
'On each row, loop through all cells until a blank is encountered
Do While rngRow.Value <> ""
'Copy the value to the target
shtTarget.Range("A" & lCount).Value = rngRow.Value
'Move one space to the right
Set rngRow = rngRow.Offset(0, 1)
'Increment counter
lCount = lCount + 1
Loop
Next rngRow
End Sub
You should end up with all the data in a single column on a new worksheet.
EDITED TO ADD: Since you mentioned your data does contain blank cells, it gets more complicated. We'll want to add a way to continue to the actual end of the data, rather than just looping until we hit a blank cell. We'll modify the Do While... condition to this:
Do While rngCell.Column <= Cells(rngCell.Row, Columns.Count).End(xlToLeft).Column
This will loop until the end of the data in the row, then move on. Give it a shot and let us know.
I have an excel workbook with two sheets. Each has exactly the same format in terms of columns. The columns are
ColA - ID
ColB - Desc/dept
ColC - Name
Sheet2 has all the information in all columns.
Sheet1 only has information in ColC.
I would like to write VBA code to compare the values in Column C for both sheets and if it matches (as they might not be in the same order or even the same number of records) then the code copies the ID and Desc from columns A and B of Sheet2(forId) into Columns A and B of sheet1(1099(2)). I wrote the following but it just runs and excel stops responding after I click on it. When I select to restart excel, nothing changed.
Thanks for your help.
Sub insertId()
Dim Rng As Range
Dim compRngI As Range, compRngO As Range
Dim wsI As Worksheet, wsO As Worksheet
Dim x As Variant, y As Variant
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'setting sheet where id to be checked
Set wsI = ThisWorkbook.Sheets("forId")
'set sheet where id to be pasted
Set wsO = ThisWorkbook.Sheets("1099(2)")
'Set ranges to be compared between sheets
With wsI
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
Set compRngI = .Range("C1:C" & lastRow)
End With
With wsO
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
Set compRngO = .Range("C1:C" & lastRow)
End With
'compare cells in both columns C of each spreadsheet
For Each x In compRngI
For Each y In compRngO
If x = y Then
y.Offset(0, -2).Value = x.Offset(0, -2).Value
y.Offset(0, -1).Value = x.Offset(0, -1).Value
End If
Next y
Next x
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
You can achieve the same result by using a MATCH and INDEX formula, and it'll run much faster than trying to do this with VBA.
The MATCH part returns a value's position in a range, and INDEX allows you to retrieve a value in a given position of a range. It's functionally similar to a VLOOKUP but allows you to return values to the left of the lookup column.
In your case, you want the following 2 formulas in columns A and B of your 1099(2) sheet:
Column A (ID)
=INDEX(Sheet1!A:A,MATCH(C2,Sheet1!C:C,0))
Column B (Desc/dept)
=INDEX(Sheet1!B:B,MATCH(C2,Sheet1!C:C,0))
The 0 in the MATCH formula means it has to find an exact match, rather than the nearest value that is less than the value being looked up (in which case you'd put 1 here) or greater than (which would be -1).
Also, a rule of thumb with Excel is that you should always try to achieve things using the built in formulas before writing your own VBA code, as the built in formulas will always be a lot faster than VBA.
I have a large number of helper rows taking information from a different sheet using a simple sum function:
=SUM('HIS-WOT'!J36,'HIS-WOT'!J82,'HIS-WOT'!J128)
Is there a macro out there that will allow me to change/offset all the row numbers in a number of selected cells by an equal amount (i.e. 221) to get a formula such as:
=SUM('HIS-WOT'!J257,'HIS-WOT'!J333,'HIS-WOT'!J349)
The amount with which I need to change the various row numbers varies, so the macro would need to have a dialogue box allowing the user to choose by how much the user wants to increase or decrease row numbers.
Thanks!
This code will give create a dummy sheet to copy the formulas over, I liked your question!
Sub test()
Dim nbr As Long, cel As Range, cels As Range, sh As Worksheet
Set cels = Selection
nbr = CLng(InputBox("Enter offset:"))
Set sh = Worksheets.Add
For Each cel In cels
If cel.HasFormula Then
sh.Cells(cel.Row + nbr, cel.Column).FormulaR1C1 = cel.FormulaR1C1
cel.Formula = sh.Cells(cel.Row + nbr, cel.Column).Formula
End If
Next
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
End Sub
I have 2 excel files with a lot of data in each. The data is structured exactly the same in both files but the values might have changed as the data is from two different times.
Basically I want to find some way to automatically compare values in each cell for the two files and highlight the cells that have changed values in file #2.
Kindly share your ideas!
Example:
File 1 :
a / 1 / 2
File 2 :
a / 1 / 8
(/ - indicates new cell)
This may not be the most efficient way (can handle 25k cells in a few seconds, though), but it more than makes up for it in simplicity.
This will look at every cell in Sheet2 and compare it against the value in the cell at the same address in Sheet1 of the file you specify. If it's different, the cell in Sheet2 is highlighted yellow.
Sub FindDifferences()
Application.ScreenUpdating = False
Dim cell As Range
Dim wkb1 As Workbook
Dim wks1 As Worksheet
Set wkb1 = Workbooks.Open(Filename:="C:\MyBook.xls")
Set wks1 = wkb1.Worksheets("Sheet1")
For Each cell In ThisWorkbook.Sheets("Sheet2").UsedRange
If cell.Value <> wks1.Cells(cell.Row, cell.Column).Value Then
cell.Interior.Color = vbYellow
End If
Next
wkb1.Close
Application.ScreenUpdating = True
End Sub
Note:
You could easily tailor this to compare 2 sheets in the same file by simple removing the wkb1 and wks1 variables and changing wks1.Cells... to Sheets("Sheet1").Cells...
You can use this online website - xlcomparator.net (click on the flag on the top right for an english version).
Or try this software: http://www.formulasoft.com/excel-compare.html
Or try this kind of macro (that check the first column) and adapt it to your needs:
sub compare()
Application.ScreenUpdating = False
Dim coll1 As New Collection, coll2 As New Collection
Dim cell1 As Range, cell2 As Range
Dim Element1 As Object, Element2 As Object
Workbooks("workbook1.xls").Activate
For Each Cellule1 In Range("a:a")
coll1.Add cell1
Next Cellule1
Workbooks("workbook2.xls").Activate
For Each cell2 In Range("a:a")
coll2.Add cell2
Next cell2
For Each Element1 In coll1
For Each Element2 In coll2
If Element1 <> Element2 Then
Element1.Font.Color = vbRed
Else
Element1.Font.Color = vbBlack
Exit For
End If
Next Element2
Next Element1
Application.ScreenUpdating = True
end sub
Source - excelabo, a french website
Two further options:
Spreadsheet Advantage, http://www.spreadsheetadvantage.com/, where you can get a free 30 day trial
This is my favourite tool as it also offers a row and column alignment option to ensure both sheets are presented indentically by row and column, before running the compare outputs code to highlight any differences
Myrna Lawson's compare.xla addin (free) available at Chip Pearson's site http://www.cpearson.com/Zips/Compare.zip