Creating macros in Excel is not my strong point so I'm wondering if someone is able to help.
I have a small table with product values, though not every cell has a value. What I'm trying to do is write a macro to create a list on a separate sheet. The macro I have written works for the first column but that's where it stops.
For example
List | aa | bb | cc
a |1 | 15 | -
b |2 | 23 | 12
c |- | 17 | 5
d |4 | - | -
Should appear on Sheet 2 like so
- List| aa
- a | 1
- b | 2
- d | 4
- List| bb
- a | 15
- b | 23
- c | 17
- List| cc
- b | 12
- c | 5
At the moment, only aa shows correctly on the 2nd sheet and none of the other columns.
The macro I have so far is
Sub Button2_Click()
Dim Column As Integer
Column = 1
newrow = 1
Do Until Worksheets("Sheet1").Cells(Column, 1).Value = ""
If Worksheets("Sheet1").Cells(Column, 2).Value <> "" Then
Worksheets("Sheet2").Cells(newrow, 1).Value = Worksheets("Sheet1").Cells(Column, 1).Value
Worksheets("Sheet2").Cells(newrow, 2).Value = Worksheets("Sheet1").Cells(Column, 2).Value
newrow = newrow + 1
End If
Column = Column + 1
Loop
End Sub
This is what I was suggesting. This code sample is based on the above sample data. If the structure of the sample changes then you will have to amend the code accordingly. I have commented the code so that you shouldn't have a problem understanding it. But if you do, simply post back :)
CODE
Option Explicit
Sub Sample()
'~~> Input/Output Sheets
Dim wsI As Worksheet, wsO As Worksheet
Dim Lrow As Long, ORow As Long, i As Long
Dim rngToFilter As Range
'~~> Set the input, output sheets
Set wsI = ThisWorkbook.Sheets("Sheet1")
Set wsO = ThisWorkbook.Sheets("Sheet2")
'~~> Set the output row in the new sheet
ORow = 1
With wsI
'~~> Get last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngToFilter = .Range("A1:D" & Lrow)
'~~> Hide Col C to E
.Range("C:E").EntireColumn.Hidden = True
'~~> Loop through Col B to Col D
For i = 2 To 4
'~~> Remove any filters
.AutoFilterMode = False
'~~> Copy Header viz List| aa, List| bb
Union(.Cells(1, 1), .Cells(1, i)).Copy wsO.Range("A" & ORow)
'~~> Get next empty row
ORow = ORow + 1
'~~> Filter, offset(to exclude headers) and copy visible rows
With rngToFilter
.AutoFilter Field:=i, Criteria1:="<>"
'~~> Copy the filtered results to the new sheet
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy wsO.Range("A" & ORow)
End With
ORow = wsO.Range("A" & wsO.Rows.Count).End(xlUp).Row + 1
'~~> Unhide/Hide relevant columns
.Columns(i).EntireColumn.Hidden = True
.Columns(i + 1).EntireColumn.Hidden = False
'~~> Remove any filters
.AutoFilterMode = False
Next i
'~~> Unhide all columns
.Range("B:E").EntireColumn.Hidden = False
End With
End Sub
SCREENSHOT
Related
I am trying to combine several worksheets into one more pivot-friendly layout.
I copy/paste from the existing worksheets into a new worksheet and rearrange the data. This works fine, but when the loop moves on to the next worksheet it adds an empty row below the data.
I know that this is a minor inconvenience but i want to wrangle the data as little as possible before turning it into a pivot table.
My code so far:
Sub NewPivot()
Dim iRow As Long, iWorksheetIndex As Long, iNumberOfWorksheets As Long, iRowCounter As Long, iCol As Long, lastCol As Long
Dim wbkSource As Workbook
Dim wksSource As Worksheet
Dim wbkTarget As Workbook
Dim wksTarget As Worksheet
Dim strActiveWorkbook As String
Workbooks.Open ("C:\\Source.xlsm")
Set wbkSource = Workbooks("Sheets.xlsm")
iWorksheetIndex = 1
Set wksSource = wbkSource.Worksheets(iWorksheetIndex)
strActiveWorkbook = ThisWorkbook.Name
Set wbkTarget = Workbooks(strActiveWorkbook)
Set wksTarget = wbkTarget.Worksheets(1)
iNumberOfWorksheets = wbkSource.Application.Sheets.Count 'Count number of worksheets
iRowCounter = 0
For iWorksheetIndex = 1 To iNumberOfWorksheets
lastCol = wbkSource.Worksheets(iWorksheetIndex).Cells(1, 1).End(xlToRight).Column
For iCol = 0 To lastCol - 2 'last Column
For iRow = 2 To 5
If wbkSource.Worksheets(iWorksheetIndex).Cells(1, 2 + iCol) <> "Sum" Then 'don't copy if the header of the data is a sum
'Copy data 01
wbkSource.Worksheets(iWorksheetIndex).Cells(iRow, 2 + iCol).Copy
wksTarget.Cells(iWorksheetIndex + iRowCounter, 1).PasteSpecial Paste:=xlPasteValues
'Copy data 02
wbkSource.Worksheets(iWorksheetIndex).Cells(1, 2 + iCol).Copy
wksTarget.Cells(iWorksheetIndex + iRowCounter, 2).PasteSpecial Paste:=xlPasteValues
'Copy data 03
wbkSource.Worksheets(iWorksheetIndex).Cells(iRow, 1).Copy
wksTarget.Cells(iWorksheetIndex + iRowCounter, 3).PasteSpecial Paste:=xlPasteValues
Else
Exit For
End If
iRowCounter = iRowCounter + 1
Next iRow
Next iCol
Next iWorksheetIndex
End Sub
EDIT: Spreadsheet layout:
Worksheet 1
Header1 | Header2
Data | Data
Data | Data
Data | Data
Worksheet 2
Header1 | Header2 | Header2
Data | Data | Data
Data | Data | Data
Data | Data | Data
Basically all worksheets contain a header and have varying numbers of columns but the same amount of rows (5)
I have the below two sheets in an excel file. I need a VBA code that will write in the column Status the value "Completed" but only if the ID is found in Sheet2. So for example, in Sheet1 I want the ID 1 to be with status "Completed", but ID 2 with blank cell in Status, because ID2 cannot be found in Sheet2. I would like to do this with a for each, as it will work faster than a simple IF formula, but I can't seem to find a code that would work. Thank you
Sheet1:
----------------------------------
ID | Product | Date | Status
-----------------------------------
1 | abc | 05-Jan-19 |
2 | abc | 07-Jan-18 |
3 | def | 05-Apr-19 |
4 | ghi | 06-Feb-19 |
Sheet2:
-------------
ID | Product
-------------
1 | abc
3 | def
4 | ghi
Use array is fast.
Sub setStatus()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim rngDB As Range
Dim vDB, vR()
Dim i As Long, n As Long
Set Ws1 = Sheets(1)
Set Ws2 = Sheets(2)
With Ws1
vDB = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With
With Ws2
Set rngDB = .Range("a2", .Range("a" & Rows.Count).End(xlUp))
End With
n = UBound(vDB, 1)
ReDim vR(1 To n, 1 To 1)
For i = 1 To n
If WorksheetFunction.CountIf(rngDB, vDB(i, 1)) Then
vR(i, 1) = "Completed"
End If
Next i
Ws1.Range("d2").Resize(n) = vR
End Sub
=IF(ISNA(MATCH(A4;Sheet2!$A$2:$A$6;0));"";"Completed")
A4 is a cell in Status column from Sheet1
$A$2:$A$6 is the range of ids from Sheet2.
Just apply this formula to all cells in Status column from Sheet1.
TheReddsable you can try below code also
Option Explicit
Dim awb, product_id As String
Dim sht_1_count, sht_2_count, loop_i, loop_d As Double
Sub get_status()
awb = ActiveWorkbook.Name
sht_1_count = Workbooks(awb).Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
sht_2_count = Workbooks(awb).Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
For loop_i = 2 To sht_1_count
product_id = Workbooks(awb).Sheets("Sheet1").Cells(loop_i, 1)
For loop_d = 2 To sht_2_count
If LCase(Trim(product_id)) = LCase(Trim(Workbooks(awb).Sheets("Sheet2").Cells(loop_d, 1))) Then
Workbooks(awb).Sheets("Sheet1").Cells(loop_i, 4) = "Completed"
Exit for
End If
Next loop_d
Next loop_i
End Sub
I made the code with the assumption that both ranges start from A1. Please, test it!
Sub BringVal()
Dim sh1 As Worksheet, sh2 As Worksheet, arrCheck As Variant, arrMatch As Variant
Dim lastRow1 As Long, lastRow2 As Long, i As Long, j As Long, arrRez As Variant
Dim boolF As Boolean
Set sh1 = Sheets(1): Set sh2 = Sheets(2) 'use here your real sheets!
lastRow1 = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row
lastRow2 = sh2.Range("A" & sh2.Rows.count).End(xlUp).Row
arrCheck = sh1.Range("A2:A" & lastRow1).Value
arrMatch = sh2.Range("A2:B" & lastRow2).Value
ReDim arrRez(1 To UBound(arrCheck))
For i = 1 To UBound(arrCheck)
For j = 1 To UBound(arrMatch, 1)
If arrCheck(i, 1) = arrMatch(j, 1) Then
boolF = True
arrRez(i) = arrMatch(j, 2): Exit For
End If
Next j
If Not boolF Then arrRez(i) = Empty
Next i
If UBound(arrRez) > 0 _
Then sh1.Range("D2:D" & UBound(arrRez) + 1).Value = _
WorksheetFunction.Transpose(arrRez)
End Sub
The code should be extremely fast, since it works only in memory and drop all the collected data at once.
If you need a message for the case of not any match found, it is so easy to add an Else ... End If sequence after the last If...
I am looping through a table in Excel with VBA to split the value into the next column. The table looks like this.
+---------------------+---------------------+
| Interval Start Date | Interval Start Time |
+---------------------+---------------------+
| 2019-07-01 04:00 | |
| 2019-07-01 05:00 | |
| 2019-07-01 05:00 | |
| 2019-07-01 05:00 | |
| 2019-07-01 06:00 | |
+---------------------+---------------------+
The first column is A the second is B.
I am using this code that I have written/acquired.
Sub SplitCells()
Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).row).Copy Destination:=Range("B2")
Dim rLastRow As Range
Dim row As Integer
Set ws = Sheets("Monthly Queue activity by hour-")
row = 2
Set rLastRow = Cells(Rows.Count, "B").End(xlUp)
rLastRow = rLastRow - 1
Dim TestArray As Variant
With ws
Do
TestArray = Split(CStr(.Cells(row, 1).Value))
.Cells(row, 2) = TestArray(1)
row = row + 1
Loop Until row = rLastRow
End With
End Sub
It will give me the Subscript Out Of Range if the timestamp I am splitting out is 00:00. I have tried searching and I can't seem to track down how to fix this.
I remove the entries with the 00:00 timestamp and it works, except I still get the Out Of Range when it reaches the end.
Since rLastRow is a range you need to call the .row property to end the Loop. This with the .Text suggestion should do the trick.
Sub SplitCells()
Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).row).Copy Destination:=Range("B2")
Dim rLastRow As Range
Dim row As Integer
Set ws = Sheets("Monthly Queue activity by hour-")
row = 2
Set rLastRow = Cells(Rows.Count, "B").End(xlUp)
rLastRow = rLastRow - 1
Dim TestArray As Variant
With ws
Do
TestArray = Split(CStr(.Cells(row, 1).Text))
.Cells(row, 2) = TestArray(1)
row = row + 1
Loop Until row = rLastRow.row + 1
End With
End Sub
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 8 years ago.
Improve this question
I want to compare "Master" worksheet with "New" worksheet based on first column value. If same is available in "New" worksheet, then I want to compare column "E" of matched row of "Master" worksheet with column "E" of matched row of "New" worksheet. If there is any diffenrence in value then replace column value "E" of "master" by column value "E" of "New" and highlight entire row by color.
Sub CompareValues()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, lr As Long, rng As Range, c As Range
Set sh1 = Sheets("New")
Set sh2 = Sheets("Master")
lr = sh2.Cells(Rows.Count, 1).End(xlUp).Row 'Get last row with data in Column A on Sheet 1.
Set rng = sh2.Range("A2:A" & lr) 'Set compare range to a variable
For Each c In rng 'Make cell by cell comparison
If Application.CountIf(sh1.Range("A:A"), c.Value) <> 0 Then
If c.EntireRow.Range("E") <> sh1.Range("E", c.Value) Then
' to fill the value into another sheet simply replace from sh1 to c.Range
c.Range("E" & i).Copy (sh1.Range("E" & i))
Range(c, sh2.Cells(c.Row, Columns.Count).End(xlToLeft)).Interior.ColorIndex = 4
End If
End If
Next
End Sub
Unfortunately I cannot comment on this question (or post pictures)...
To clarify (assuming my third column would be column 'E'):
If sheet "Master" looks like this:
| first | info | d'oh |
| two | info | 4 |
| three | info | hello |
and "New" looks like that:
| first | info | d'oh |
| two | blub | 5 |
| wheee | cool | cool |
you want that as a result:
| first | info | d'oh |
| two | info | 5 | <- highlighted
| three | info | hello |
My solution:
Sub UpdateSheet()
Dim masterSheet As Excel.Worksheet, newSheet As Excel.Worksheet
Dim e, masterCell As Excel.Range, newCell As Excel.Range
Dim columnOffset As Integer
Const idColumn = 1 'column A has index 1
Const newDataColumn = 5 'column E has index 5
columnOffset = newDataColumn - idColumn 'offset between those columns is 4
Set masterSheet = ThisWorkbook.Sheets("Master")
Set newSheet = ThisWorkbook.Sheets("New")
'iterate over all cells of the first column in the used range of this worksheet
For Each e In masterSheet.UsedRange.Columns(idColumn).Cells
Set masterCell = e
Set newCell = newSheet.Cells(masterCell.Row, idColumn)
'if the cell on the master sheet is not empty and the values of both cells match
If masterCell.Value <> Empty And masterCell.Value = newCell.Value Then
'select cells in column "E"
Set masterCell = masterCell.Offset(0, columnOffset)
Set newCell = newCell.Offset(0, columnOffset)
'copy values and paint row if values don't match
If masterCell.Value <> newCell.Value Then
masterCell.Value = newCell.Value
masterCell.EntireRow.Interior.ColorIndex = 4
End If
End If
Next e
End Sub
I updated your solution to fit my requirement. Thanks for your help.
Sub UpdateSheet()
Dim masterSheet As Excel.Worksheet, newSheet As Excel.Worksheet
Dim e, n, masterCell As Excel.Range, newCell As Excel.Range
Dim columnOffset As Integer
Const idColumn = 1 'column A has index 1
Const newDataColumn = 5 'column E has index 5
columnOffset = newDataColumn - idColumn 'offset between those columns is 4
Set masterSheet = ThisWorkbook.Sheets("Master")
Set newSheet = ThisWorkbook.Sheets("New")
'iterate over all cells of the first column in the used range of this worksheet
For Each e In masterSheet.UsedRange.Columns(idColumn).Cells
Set masterCell = e
If masterCell.Value <> Empty Then
For Each n In newSheet.UsedRange.Columns(idColumn).Cells
Set newCell = n
'if the cell on the master sheet is not empty and the values of both cells match
If masterCell.Value = newCell.Value Then
'select cells in column "E"
Set masterCell = masterCell.Offset(0, columnOffset)
Set newCell = newCell.Offset(0, columnOffset)
'copy values and paint row if values don't match
If masterCell.Value <> newCell.Value Then
masterCell.Value = newCell.Value
masterCell.EntireRow.Interior.ColorIndex = 4
End If
End If
Next n
End If
Next e
End Sub
I'm trying to create a macro that selects the range of last row and last column.
E.g. I want to select 1, 2, 3, 4 from my spreadsheet and then delete the selection.
Data:
John | 10 | 10 | 10
Smith | 5 | 5 | 5
Fred | 8 | 8 | 8
1 | 2 | 3 | 4
Here is my code, it only selects the the last row on the A column. (selects 1 and deletes it). I need it to select 1 to 4 and delete the whole row.
Range("A" & Rows.Count).End(xlUp).Select
Selection.Delete Shift:=xlUp
Is this what you are trying? I have commented the code so that you will not have any problem understanding it.
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, lCol As Long
Dim rng As Range
'~~> Set this to the relevant worksheet
Set ws = [Sheet1]
With ws
'~~> Get the last row and last column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'~~> Set the range
Set rng = .Range(.Cells(lRow, 1), .Cells(lRow, lCol))
With rng
Debug.Print .Address
'
'~~> What ever you want to do with the address
'
End With
End With
End Sub
BTW I am assuming that LastRow is the same for all rows and same goes for the columns. If that is not the case then you will have use .Find to find the Last Row and the Last Column. You might want to see THIS
The simplest modification (to the code in your question) is this:
Range("A" & Rows.Count).End(xlUp).Select
Selection.EntireRow.Delete
Which can be simplified to:
Range("A" & Rows.Count).End(xlUp).EntireRow.Delete
Another simple way:
ActiveSheet.Rows(ActiveSheet.UsedRange.Rows.Count+1).Select
Selection.EntireRow.Delete
or simpler:
ActiveSheet.Rows(ActiveSheet.UsedRange.Rows.Count+1).EntireRow.Delete