I have in E, F and I columns something written. In E and F its a name and in I its a number. In I column there are some cells with number and rest are blank. When ever its a number, I should copy the names from E1, F1 and copy it to C3 and D3 respectively. I have written a code but its not functioning properly. Could you please help me.
Option Explicit
Sub copy()
Dim cell As Long
Dim nr As Integer
Dim rng As range
Dim i As Long
range("G1:G15").Select
Selection.CurrentRegion.Select
nr = Selection.Rows.Count
For i = 2 To nr
'test if cell is empty
If ActiveCell(i, 7) = "" Then
'write to adjacent cell
ActiveCell = ActiveCell + 1
Else
ActiveCell.Offset(-3, -2).Value.copy ActiveCell.Offset(-3, 0)
End If
Next i
End Sub
Option Explicit
Sub copy()
Dim Row As Long
Dim Col As Long
Row = 2
Col = 9
Do Until Cells(Row, 5).Value = ""
If IsNumeric(Cells(Row, Col)) = True Then
Range("E" & Row & ":F" & Row).copy
Range("C" & Row).PasteSpecial (xlPasteValues)
End If
Row = Row + 1
Loop
Application.CutCopyMode = False
End Sub
Related
I have been struggling with this code. I want to loop through Column E beginning with E5, on the Sheet titled "pivot of proposal" (which is a pivot table); and every time it finds a cell with the value of "check" I want it to copy/paste value of cells A & B of the corresponding row to the sheet titled Check Payments in E & F, moving down a row each time but beginning on row 4. I tried to piece together other bits of code but it is not doing what I need it to.
Sub Loop_Check_Payments()
Dim c As Range
Dim IRow As Long, lastrow As Long, krow as long
Dim copyrow As Integer
Dim rSource As Range
Dim DataOrigin As Worksheet, DataDest As Worksheet, DataDestACH As Worksheet
On Error GoTo Whoa
'~~> Sheet Where "L" needs to be checked
Set DataOrigin = ThisWorkbook.Sheets("Pivot of proposal")
'~~> Output sheet
Set DataDest = ThisWorkbook.Sheets("CHECK PAYMENTS")
Set DataDestACH = ThisWorkbook.Sheets("ACH_WIRE PAYMENTS CASH POOLER")
Application.ScreenUpdating = False
'~~> Set you input range
Set rSource = Range("Payment_Method")
'~~> Search for the cell which has "L" and then copy it across to sheet1
For Each c In rSource
If c.Value = "Check" Then
DataDest.Cells(4 + IRow, 5) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(4 + IRow, 6) = DataOrigin.Cells(c.Row, 2)
IRow = IRow + 1
Else
DataDestACH.Cells(4 + kRow, 7) = DataOrigin.Cells(c.Row, 1)
DataDestACH.Cells(4 + kRow, 8) = DataOrigin.Cells(c.Row, 2)
kRow = kRow + 1
End If
Next c
Whoa:
MsgBox Err.Description
End Sub
Instead of trying to Copy/paste - you can do something like this (as PeterT alluded to in comments)
this will put values from columns A&B (ordinal 1 & 2) of the SOURCE to the same row/column in the destination:
If c.Value = "Check" Then
DataDest.Cells(c.Row, 1) = DataOrigin.Cells(c.Row, 1)
DataDest.Cells(c.Row, 2) = DataOrigin.Cells(c.Row, 2)
End If
I am working on a dynamic worksheet which the total rows and columns of content will be changing.
What I try to do is, making an active cell going through the worksheet. It starts from the very last column that has content (I used UsedRange here), and from the 7st row down to the last row not blank.
When 1) The active cell has a color filling of index 16 or 36; 2) The active cell has no value, the cell will fetch the value storing in the matching row E.
The loop will end when hitting column E (I haven't been able to go that far yet).
I will attach my code below for all possible help, since it complies but does not return any result...Thank you again!
Sub catchCurrentAutomated()
Dim column As Integer
Dim row As Integer
Dim Cell As Range
row = 7
column = ActiveSheet.UsedRange.Columns.Count
Set Cell = ActiveCell
While range("A" & row) <> ""
If Cell.Interior.ColorIndex = 16 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
ElseIf Cell.Interior.ColorIndex = 36 And _
IsEmpty(Cell.Value) = True Then
Cell.Value = Cells(ActiveCell.row, "E").Value
End If
row = row + 1
column = column - 1
Wend
End Sub
Something like this should work (untested)
Sub catchCurrentAutomated()
Dim col As Long '<< use Long not Integer
Dim row As Long
Dim c As Range, ws As Worksheet, lr As Long, indx
Set ws = ActiveSheet
col = ws.UsedRange.Columns.Count
lr = ws.Cells(Rows.Count, 1).End(xlUp).row 'last occupied cell in ColA
Do While col > 5
For row = 7 To lr
With ws.Cells(row, col)
indx = .Interior.Color.Index
If (indx = 16 Or indx = 36) And Len(.Value) = 0 Then
.Value = ws.Cells(row, "E").Value
End If
End With
Next row
col = col - 1 'next column to left
Loop
End Sub
I have the following excel
I am trying the following code
> Sub fill_blanks()
Dim i As Long
i = 2 '
Do Until Range("B" & i) = ""
Range("B" & i).Select
If ActiveCell.FormulaR1C1 <> "" Then
Range("A" & i).Select
If ActiveCell.FormulaR1C1 = "" Then
Range("A" & i - 1).Copy
Range("A" & i).PasteSpecial Paste:=xlPasteValues
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End Sub >
What I need to check is if the cell is not empty, then to keep its value, and if it was empty to check the first next not empty cell and the previous non empty cell in the same column, and if they have the same value, then to fill all the empty cells between with the same value, and if the two cells are not matching, then to return X.
So the result will be as following
But using the code , I am getting something different.
This what I get with this code
Find the last used row LastRow so we know where to stop.
Loop through your rows, when you come accross an epmty cell remember it FirstEmptyRow
Keep looping until you find data again, the row before is then LastEpmtyRow. Now we know the beginning and the end of the empty space.
Check if above the epmty space and below the empty space is the same date. If so fill it into the empty space otherwise fill in x.
So you end up with something like
Option Explicit
Public Sub FillData()
Const START_ROW As Long = 2 'define first data row
Const COL As String = "A" 'define the column
Dim ws As Worksheet 'define your worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long 'find last used row in column A
LastRow = ws.Cells(ws.Rows.Count, COL).End(xlUp).Row
Dim FirstEmptyRow As Long, LastEpmtyRow As Long 'first and last empty row of a empty range
Dim iRow As Long
For iRow = START_ROW To LastRow
If ws.Cells(iRow, COL).Value = vbNullString And FirstEmptyRow = 0 Then
'found first row of an empty range
FirstEmptyRow = iRow
ElseIf ws.Cells(iRow, COL).Value <> vbNullString And FirstEmptyRow <> 0 Then
'found last row of an empty range
LastEpmtyRow = iRow - 1
'check if same date to fill either the date or x
If ws.Cells(FirstEmptyRow - 1, COL).Value = ws.Cells(LastEpmtyRow + 1, COL).Value Then
'fill date
ws.Range(ws.Cells(FirstEmptyRow, COL), ws.Cells(LastEpmtyRow, COL)).Value = ws.Cells(FirstEmptyRow - 1, COL).Value
Else
'fill x
ws.Range(ws.Cells(FirstEmptyRow, COL), ws.Cells(LastEpmtyRow, COL)).Value = "x"
End If
'reset variables
FirstEmptyRow = 0
LastEpmtyRow = 0
End If
Next iRow
End Sub
Image 1: Illustration of the process.
I have two sheets Report and Stat. I need to match cell from Report with Stat and Stat with report.
I don't know what I'm missing :(
I try to loop with For, If, IF Not
Sub Test1()
Dim x As Integer
Application.ScreenUpdating = False
Rows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Range("A2").Select
For x = 1 To Rows
If ActiveCell.Value = Stat.Range("A").Value Then ActiveCell.Offset(0, 11).Value = "Old"
If Not ActiveCell.Value = Stat.Range("A").Value Then ActiveCell.Offset(0, 11).Value = "New"
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Sheets("Stat").Select
Rows2 = Range("A1", Range("A1").End(xlDown)).Rows.Count
Range("A2").Select
For x = 1 To Rows2
If Not ActiveCell.Value = Report.Range("A").Value Then ActiveCell.Offset(0, 11).Value = "Cleared"
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
I need to match all cells in column A and try to match with any cell in column A in Stat Sheet.
If it match then offset 11 cell Report sheet to the right and add value "Old" to the cell.
If it doesn't match then Off offset 11 cell in Report sheet to the right and add value "New".
The last thing I need to match all cells in column A from Stat Sheet and try to match with any cell in column A in Report Sheet.
If it match then nothing
If it doesn't match then sheet Stat offset 11 to the right and add value "Cleared"
I'm still looking working on this but can't figure it out :/
This could help you:
Option Explicit
Sub Loop_Loop()
Dim LastrowReport As Long, LastrowStat As Long, i As Long, y As Long
Dim ValueReport As String, ValueStat As String
'Find Report sheet last row (Column A)
LastrowReport = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
'Find Stat sheet last row (Column A)
LastrowStat = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
'Loop value in sheet Report, column A (starting from second row)
For i = 2 To LastrowReport
'Value in sheet Report, Column A i row
ValueReport = Sheet1.Range("A" & i).Value
'Loop value in sheet Stat, column A (starting from second row)
For y = 2 To LastrowStat
'Value in sheet Stat, Column A y row
ValueStat = Sheet2.Range("A" & y).Value
'Check if ValueReport & ValueStat is equal
If ValueReport = ValueStat Then
MsgBox "Same Values!"
End If
Next y
Next i
End Sub
ERROR 4001
I follow your advise but this time I can't have "Old" "New" and "Clear" the word overlap in the same cell :(
Option Explicit
Sub Loop_Loop()
Dim LastrowReport As Long, LastrowStat As Long, i As Long, y As Long
Dim ValueReport As String, ValueStat As String
LastrowReport = Sheet10.Cells(Sheet10.Rows.Count, "A").End(xlUp).Row
LastrowStat = Sheet12.Cells(Sheet12.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastrowReport
ValueReport = Sheet10.Range("A" & i).Value
For y = 2 To LastrowStat
ValueStat = Sheet12.Range("A" & y).Value
If ValueReport = ValueStat Then
Activecell.offset(0, 11).Value = "Old"
If Not ValueReport = ValueStat Then
Activecell.offset(0, 11).Value = "New"
If Not ValueStat = ValueReport Then
Activecell.offset(0, 11).Value = "Clear"
End If
Next y
Next i
End Sub
basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA