I need a VBA code for copying the red colored cell content (its value), its and sheet name for that cell and Paste into in the new sheet in the workbook.
For Example there is Workbook having 3 sheets into it. And every sheet contains cells marked in red. I want to copy the cell text, cell address and sheet for this and Paste into the new sheet.
Please help on this.
This will do what you are looking for. Just using simple loops, first through the worksheets, then rows, then columns.
It will loop through all the worksheets in the workbook, exclude the master sheet, and examine the Interior color of the cell, and report to the Master sheet what the Sheet, Address, Value, Row, Columns are...
TESTED:
Sub ColorChecker()
Dim lastRow As Long
Dim lastCol As Long
Dim ws As Worksheet
Dim masterSheet As String
Dim mRow As Long
Dim lRow As Long
Dim lCol As Long
mRow = 2
masterSheet = "Master" 'Set the name of the Master Sheet
For Each ws In Worksheets
If ws.Name <> masterSheet Then
lastRow = Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).row
lastCol = Sheets(ws.Name).Cells(1, Columns.Count).End(xlToLeft).Column
For lRow = 2 To lastRow
For lCol = 1 To lastCol
If Sheets(ws.Name).Cells(lRow, lCol).Interior.ColorIndex = 3 Then
Sheets(masterSheet).Cells(mRow, 1) = ws.Name
Sheets(masterSheet).Cells(mRow, 2) = LongToRange(lRow, lCol)
Sheets(masterSheet).Cells(mRow, 3) = Sheets(ws.Name).Cells(lRow, lCol).Value
Sheets(masterSheet).Cells(mRow, 4) = lRow
Sheets(masterSheet).Cells(mRow, 5) = lCol
mRow = mRow + 1
End If
Next lCol
Next lRow
End If
Next ws
End Sub
This function will create a named Range based on your Column and Row numbers.
Function LongToRange(row As Long, col As Long) As String
Dim tempRange As String
tempRange = Chr(34) & ConvertToLetter(CInt(col)) & row & Chr(34)
LongToRange = tempRange
End Function
This function is from How to Convert Excel Column Numbers to Letters
Function ConvertToLetter(iCol As Integer) As String
'FROM support.microsoft.com/kb/833404
Dim iAlpha As Integer
Dim iRemainder As Integer
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
ConvertToLetter = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
ConvertToLetter = ConvertToLetter & Chr(iRemainder + 64)
End If
End Function
Related
I have a macro that copies rows from a Sheet named "Template" and pastes them onto the Active Sheet in the next blank row.
However this macro only works when the grouped cells on the Active Sheet are expanded.
If the grouped cells are collapsed, then the macro replaces a previous collapsed group.
I have done some reading and discovered that using a different method to calculate the last row i.e. the MergeArea property would work with collapsed groups but just sure how to apply it.
How could I achieve this with the current code?
This is my code:
Sub Paste_New_Product_from_Template()
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim LRow As Long, i As Long
Dim StartNumber As Long
Dim varString As String
'~~> This is your input sheet
Set copySheet = ThisWorkbook.Worksheets("Template")
'~~> Variable
varString = copySheet.Cells(2, 2).Value2
'~~> Change this to the relevant sheet
Set pasteSheet = ThisWorkbook.ActiveSheet
'~~> Initialize the start number
StartNumber = 1
With pasteSheet
'~~> Find the last cell to write to
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
LRow = 2
Else
LRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
'~~> Find the previous number
For i = LRow To 1 Step -1
If .Cells(i, 2).Value2 = varString Then
StartNumber = .Cells(i, 6).Value2 + 1
Exit For
End If
Next i
End If
copySheet.Range("2:" & copySheet.Cells(Rows.Count, 1).End(xlUp).Row).Copy
.Rows(LRow).PasteSpecial Paste:=xlPasteAll
'~~> Set the start number
.Cells(LRow, 6).Value = StartNumber
'~~> Format the number
.Cells(LRow, 6).Value = "'" & Format(StartNumber, "000")
End With
End Sub
Here is the code that uses the MergeArea procedure:
Private Function RowIsEmpty(WSh As Worksheet, Row As Long, StartColumnNumber As Integer, EndColumnNuber As Integer) As Boolean
Dim j As Integer
RowIsEmpty = True
For j = StartColumnNumber To EndColumnNuber
If (WSh.Cells(WSh.Cells(Row, j).MergeArea.Row, WSh.Cells(Row, j).MergeArea.Column) <> "") Then
RowIsEmpty = False
Exit For 'One of columns isn't empty
End If
Next j
End Function
Private Function CalcLastRowNumber(WSh As Worksheet, StartColumnNumber As Integer, EndColumnNuber As Integer) As Long
Dim i As Long
Dim j As Integer
Dim Result As Long
Dim Found As Boolean
Result = 1
For i = 1 To Rows.Count
If RowIsEmpty(WSh, i, StartColumnNumber, EndColumnNuber) And _
RowIsEmpty(WSh, i + 1, StartColumnNumber, EndColumnNuber) And _
RowIsEmpty(WSh, i + 2, StartColumnNumber, EndColumnNuber) Then
'Stop searching
Exit For 'All Columns are empty for current row and for next 2 rows
End If
Result = i
Next i
CalcLastRowNumber = Result
End Function
Sub New_Reviss_Order()
What I want to achieve is to use values via a loop in another module.
My Excel file has 3 columns with each column 2 rows.
I want to use the values in each row (3 columns) inside an other method.
My loop script
Sub Loops()
Dim lRow As Long
Dim lCol As Long
Dim ws As Worksheet
Dim rng As Range, cell As Range
Set rng = Range("E1")
Set ws = Sheet1
Row = 1
lRow = Cells(Rows.Count, 1).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For Each cell In rng
For icol = 1 To lCol
For irow = 1 To lRow
cell(Row).Value = ws.Cells(irow, icol)
Row = Row + 1
Next irow
Next icol
Next cell
End Sub
Main Script
Sub Main()
Dim text1 As String
Dim text2 As String
Dim text3 As String
text1 = ThisWorkbook.Sheets(1).Range("A1")
text2 = ThisWorkbook.Sheets(1).Range("B1")
text3 = ThisWorkbook.Sheets(1).Range("C1")
Debug.Print text1; text2; text3
End Sub
As you can see in the Main script I have put in a hard link to the info that I need.
So I want to first get the values of row 1 (Columns A, B & C) and do something.
When this is done I want to get the values of row 2 (Columns A, B & C) and do something.
I want this to go through untill there are no more rows.
Can anyone point me in the right direction on how to achieve this? Thank you.
UPDATE
This is my excel file
So the Main Script should give as result
text1 = 1
text2 = 3
text3 = 5
When this is done the Main Script should run again. With result.
text1 = 2
text2 = 4
text3 = 6
And as there is no more row the script needs to stop.
If you want to do the same thing for every cell do something like this
Public Sub LoopingLouiCellWise()
Dim ws As Worksheet
Set ws = Sheet1
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim iRow As Long
For iRow = 1 To LastRow 'loop through all rows
Dim iCol As Long
For iCol = 1 To LastCol 'loop through columns in this row
'either put your entire code to do something here
'…
'or call a sub procedure
DoSomethingWithCell ws.Cells(iRow, iCol)
Next iCol
Next iRow
End Sub
Private Sub DoSomethingWithCell(ByVal Cell As Range)
'your code here
Debug.Print Cell.Address
End Sub
If you want to do "something" with the entire row (row wise) then do something like this
Public Sub LoopingLouiRowWise()
Dim ws As Worksheet
Set ws = Sheet1
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim LastCol As Long
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim iRow As Long
For iRow = 1 To LastRow 'loop through all rows
DoSomethingWithRow iRow, LastCol, ws
Next iRow
End Sub
Private Sub DoSomethingWithRow(ByVal iRow As Long, ByVal LastCol As Long, ByVal ws As Worksheet)
'your code here
Dim iCol As Long
For iCol = 1 To LastCol
Debug.Print ws.Cells(iRow, iCol)
Next iCol
End Sub
Note that in this version you need to tell your procedure in which worksheet ws you are working.
i am trying to populate 4 coulms and 130 rows from b2:b130 in display sheet using vlookup from bills sheet using rowid i created.
my data as in attached image.if anyone can help me with this that will be great.
Try the next code, please. It should be very fast and does not increase the workbook size like in case of formulas:
Sub copyRangeForSpecRows()
Dim firstRow As Long, lastRow As Long, shS As Worksheet, shD As Worksheet, El As Variant
Dim arrEX As Variant, arrGY As Variant, arrIZ As Variant, arrKAA As Variant
Dim pasteRow As Long, lastCopyRow As Long, arrRows As Variant, i As Long, k As Long
Set shS = Sheets("Bills") 'use here your sheet to copy from
Set shD = Sheets("Display")
firstRow = 5: lastRow = 130
pasteRow = CLng(shD.Range("T" & firstRow).Value)
lastCopyRow = CLng(shD.Range("T" & firstRow + lastRow).Value)
ReDim arrEX(1 To lastRow, 1 To 1): ReDim arrGY(1 To lastRow, 1 To 1)
ReDim arrIZ(1 To lastRow, 1 To 1): ReDim arrKAA(1 To lastRow, 1 To 1)
arrRows = shD.Range(shD.cells(firstRow, "T"), shD.cells(lastRow + firstRow - 1, "T")).Value
For i = pasteRow To lastCopyRow
For Each El In arrRows
If i = CLng(El) Then
k = k + 1
arrEX(k, 1) = shS.Range("X" & i).Value
arrGY(k, 1) = shS.Range("Y" & i).Value
arrIZ(k, 1) = shS.Range("Z" & i).Value
arrKAA(k, 1) = shS.Range("AA" & i).Value
End If
Next
Next i
shD.Range("E5:E" & 4 + lastRow).Value = arrEX
shD.Range("G5:G" & 4 + lastRow).Value = arrGY
shD.Range("I5:I" & 4 + lastRow).Value = arrIZ
shD.Range("K5:K" & 4 + lastRow).Value = arrKAA
MsgBox "Ready..."
End Sub
Based on how small scale this is and where you said you are just a starter with vba, I kept it simple(ish) while getting the desired result.
Commented for understanding.
Option Explicit
Sub populateData()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsDisp As Worksheet: Set wsDisp = wb.Worksheets("Display")
Dim wsBill As Worksheet: Set wsBill = wb.Worksheets("Bills")
Dim LastRow As Long
Dim i As Long
LastRow = wsDisp.Cells(wsDisp.Rows.Count, "B").End(xlUp).Row ' finds the last row in column B of the "Display" worksheet
On Error Resume Next ' bypasses errors such as unmatched values
For i = 1 To LastRow ' loop until the last row containing data
wsDisp.Cells(i, 5).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 24) ' populates "GIDC Gas Paid" row in "Display" worksheet
wsDisp.Cells(i, 7).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 25) ' populates "GST-GIDC Gas Paid" row in "Display" worksheet
wsDisp.Cells(i, 9).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 26) ' populates "GIDC Booking Paid" row in "Display" worksheet
wsDisp.Cells(i, 11).Value = wsBill.Cells(Application.Match(wsDisp.Cells(i, 20).Value, wsBill.Range("W:W"), 0), 27) ' populates "GST-GIDC Booking Paid" row in "Display" worksheet
Next i ' iterates to the next number in the loop
End Sub
You should use index and Match function instead of Vlookup and if you want hard code then i will suggest you that go from row 1 to lastrow and check if both Sr.No and RowId match then take that data into an array and at the last paste the array data in Display Sheet.
I'm trying to copy all rows from between two cell values and paste the values in a new column in a new worksheet. Let's say my data is structured in one excel column as such:
x
1
2
3
y
x
4
5
6
y
So I want to copy the 123 and the 456, paste them in a new worksheet in columns A and B respectively, like so:
A B
1 1 4
2 2 5
3 3 6
The code that I have working copies the data just fine, but it only pastes them below each other. Is there any way to amend the following code to paste the copied data in a new column every time the loop runs through?
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
rownum = 1
colnum = 1
lastrow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
Do
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
rownum = rownum + 1
If (rownum > lastrow) Then Exit For
Loop Until .Cells(rownum, 1).Value = "y"
endrow = rownum - 1
rownum = rownum + 2
Worksheets("Sheet1").Range(startrow & ":" & endrow).Copy
Sheets("Sheet2").Select
ActiveSheet.Range("A1").Select
ActiveSheet.Paste
Next rownum
End With
End Sub
There's a lot going on in that code that doesn't need to. Have a look at the below and see if you can follow what's happening:
Private Sub CommandButton1_Click()
Dim rownum As Long
Dim colnum As Long
Dim startrow As Long
Dim endrow As Long
Dim lastrow As Long
colnum = 1 'start outputting to this column
Dim rangetocopy As Range
With Worksheets("Sheet1")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
With ActiveWorkbook.Worksheets("Sheet1").Range("A1:A" & lastrow)
For rownum = 1 To lastrow
If .Cells(rownum, 1).Value = "x" Then
startrow = rownum
End If
If .Cells(rownum, 1).Value = "y" Or rownum = lastrow Then
endrow = rownum
Set rangetocopy = Worksheets("Sheet1").Range("A" & startrow & ":A" & endrow)
rangetocopy.Copy Sheets("Sheet2").Cells(1, colnum)
colnum = colnum + 1 ' set next output column
End If
Next rownum
End With
End Sub
you could use:
SpecialCells() method of Range object to catch "numeric" values range
Areas property of Range object to loop through each set of "numeric" range
as follows:
Sub CommandButton1_Click()
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)
Dim area As Range
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
to manage data of any format (not only "numeric") between "x"s or "x"s and "y"s, then use
AutoFilter() method of Range object to filter data between "x"s or "x"s and "ys" "
SpecialCells() method of Range object to catch not empty values range
Areas property of Range object to loop through each set of "selected" range
as follows:
Sub CommandButton1_Click()
Dim area As Range
With Worksheets("Sheet1")
With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>x", Operator:=xlAnd, Criteria2:="<>y"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants) '.Offset(-1)
For Each area In .Areas
With Worksheets("Sheet2")
.Cells(1, .Columns.Count).End(xlToLeft).Offset(, 1).Resize(area.Rows.Count).Value = area.Value
End With
Next
End With
End With
.AutoFilterMode = False
End With
Worksheets("Sheet2").Columns(1).Delete
End Sub
This type was already mentioned, but since I wrote it, I'll share it as well, using range areas.
This is also assuming layout is actual in the original question and that you are trying to extract a group of numbers.
Sub Button1_Click()
Dim sh As Worksheet, ws As Worksheet
Dim RangeArea As Range
Set sh = Sheets("Sheet1")
Set ws = Sheets("Sheet2")
For Each RangeArea In sh.Columns("A").SpecialCells(xlCellTypeConstants, 1).Areas
RangeArea.Copy ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1)
Next RangeArea
End Sub
I am trying to make a command button copy data from the main sheet "all" into 4 different sheets based on wether or not they meet the requirement. i have made it work with my "Lending" with the code bellow, but in the next 3 columns i have the data "FX" "Account" and "Payments" and i would like to have this one command button work with all of the sheets. Some of the dato points will go into multiple sheets, while some would only live up to 1 of them. Anyone who knows how i can expand the code to make it work?
Private Sub CommandButton1_Click()
Dim AllSheet As Worksheet
Dim LendSheet As Worksheet
Dim LastRow As Integer
Dim RowCnt As Integer
Dim DestRow As Integer
Set AllSheet = ActiveWorkbook.Sheets("All")
Set LendSheet = ActiveWorkbook.Sheets("Lending")
With AllSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
DestRow = LendSheet.Range("A" & LendSheet.Rows.Count).End(xlUp).Row + 1
For RowCnt = 2 To LastRow
If .Cells(RowCnt, 3).Value = "X" Or .Cells(RowCnt, 3).Value = "x" Then
LendSheet.Rows(DestRow).Value = .Rows(RowCnt).Value
DestRow = DestRow + 1
End If
Next
End With
'..... Remove Duplicates
Dim LastCol As String
With LendSheet
LastCol = Split(.Range("A1").End(xlToRight).Address, "$")(1)
.Range("A:" & LastCol).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7),
Header:=xlYes
End With
End Sub
The "copy data to another sheet" can be split out into a separate sub, and that cleans up your main code, making it easier to add new checks.
Private Sub CommandButton1_Click()
Dim AllSheet As Worksheet
Dim LastRow As Long
Dim RowNum As Long
Set AllSheet = ActiveWorkbook.Sheets("All")
With AllSheet
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For RowNum = 2 To LastRow
If UCase(.Cells(RowNum, 3).Value) = "X" Then
AppendRow .Rows(RowNum), "Lending"
End If
If UCase(.Cells(RowNum, 4).Value) = "BLAH" Then
AppendRow .Rows(RowNum), "FX"
AppendRow .Rows(RowNum), "Account" '<< can copy to >1 sheet...
End If
Next
End With
'..... Remove Duplicates
End Sub
'append a range to a named sheet
Sub AppendRow(rwSrc As Range, shtName As String)
Dim rw As Range
Set c = ActiveWorkbook.Sheets(shtName).Cells(Rows.Count, 1).End(xlUp) _
.Offset(1, 0).Resize(1, rwSrc.Columns.Count)
'make sure we're really copying to a blank row...
Do While Application.CountA(rw) > 0
Set rw = rw.Offset(1, 0)
Loop
rw.Value = rwSrc.Value
End Sub