This is my Excel sheet. Columns G and Column J have the same values but in different order.
The code runs and moves the values from Column J to Column H, beside the same value of column G.
The problem with this is that when there are two values the same it moves it to the first value it finds in Column H. The value 747.00 in J:2 must move to H:2 while the value 747.00 in J:5 must move to H:6 not to H:2.
This is the code:
Dim cel As Range, cel2 As Range
Dim lastRow As Long
lastRow = Cells(Rows.Count, 10).End(xlUp).Row
For Each cel In Range(Cells(1, 7), Cells(lastRow, 7))
For Each cel2 In Range(Cells(1, 10), Cells(lastRow, 10))
If cel2.Value = cel.Value Then
cel.Offset(0, 1).Value = cel2.Value
cel2.Value = ""
End If
Next cel2
Next cel
It sounds like you are cycling through column J and looking for a match in column G. I've reversed that by cycling through column G and looking for a match in column J. Once one match has been found it is moved over to column H thereby removing it from column J.
Sub match_em_up()
Dim rwg As Long, rwj As Long
With Worksheets("Sheet1")
For rwg = 2 To .Cells(Rows.Count, "G").End(xlUp).Row
If CBool(Application.CountIf(.Columns("J"), .Cells(rwg, "G").Value2)) Then
rwj = Application.Match(.Cells(rwg, "G").Value2, .Columns("J"), 0)
.Cells(rwg, "H") = .Cells(rwj, "J").Value2
.Cells(rwj, "J").ClearContents
End If
Next rwg
End With
End Sub
Before:
After:
Related
I have some spreadsheet data that will be in multiples columns but the number of columns will vary from 1 to 8 based on the number of entries. I have some entries that start with the same 2 characters in this format: CF 12456 There could be only 1 of these or many of these "CF 12345"s Once the data is spread out into evenly distributed columns, I need to move all the cells with a "CF 12345" into a new column that will be the last column of data (i.e. if there are 6 columns of data, the "CF 12345" column should be to the right of column 6). This code does all of that except it moves all the "CF 12345"s to column I (yes, I know its because that is what the code is telling it to do). Here is the code:
Sub DiscrepancyReportMacroStepTwo()
'Step 4: Find CF cells move to the top of their own column
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Sheet1").Range("A2:H500")
For Each cell In rngA
If cell.Value Like "*CF*" Then
cell.Copy cell.Offset(0, 1)
cell.Clear
End If
Next cell
End Sub
Iterate on the columns of the used range and for each found cell matching the pattern, swap its value with the top cell. If you need to keep all the cell values, you need to track the current top row where you need to swap.
By the way, your pattern seems to be "CF *", not "*CF*", unless you made a mistake in the problem description. This code will move all your CF * cells to the top while preserving all values existing in the worksheet.
Sub DiscrepancyReportMacroStepTwo()
Dim cel As Range, col As Range, curRow As Long, temp
For Each col In Sheets("Sheet1").UsedRange.Columns
curRow = 1
For Each cel In col.Cells
If cel.Value2 Like "CF *" Then
' Swap values of the cell and a cel from top of the column (at curRow)
temp = col.Cells(curRow).Value2
col.Cells(curRow).Value2 = cel.Value2
cel.Value2 = temp
curRow = curRow + 1
End If
Next cel
Next col
End Sub
EDIT
The above code moves the CF * cells to the top of the column. To add them in a new separate column, use this:
Sub DiscrepancyReportMacroStepTwo()
Dim lastColumn As Long, lastRow As Long, cel As Range, curRow As Long
With Sheets("Sheet1")
lastColumn = .Cells.Find("*", , xlFormulas, xlPart, xlByColumns, xlPrevious).Column
lastRow = .Cells.Find("*", , xlFormulas, xlPart, xlByRows, xlPrevious).row
For Each cel In .Range("A2", .Cells(lastRow, lastColumn))
If cel.Value2 Like "CF *" Then
curRow = curRow + 1
.Cells(curRow, lastColumn + 1).Value2 = cel.Value2
cel.Clear
End If
Next cel
End With
End Sub
You can use a regular expression to look for the 'CF *' values which will ensure that you select only values that start with 'CF ' followed by 5 digits as per your problem statement. If you don't know the # of digits but know it'll be between 2 and 5 digits, you can change the regular expression pattern to: "^CF [\d]{2,5}$"
Option Explicit
Sub Move2LastCol()
Dim sht As Worksheet
Set sht = Worksheets("Sheet1")
Dim regEx As Object
Set regEx = CreateObject("vbscript.regexp")
regEx.Pattern = "^CF [\d]{5}$"
Dim r As Integer, c As Integer, lastRow As Integer, lastCol As Integer
Dim tmp As String
With sht
lastCol = .Cells.Find(What:="*", SearchOrder:=xlColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column + 1
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = 1 To lastRow:
Dim c1 As Integer: c1 = lastCol
For c = 1 To .Cells(r, lastCol).End(xlToLeft).Column:
If regEx.Test(.Cells(r, c)) Then
tmp = .Cells(r, c).Value2
.Cells(r, c).Clear
.Cells(r, c1).Value2 = tmp
c1 = c1 + 1
Exit For
End If
Next
Next
End With
End Sub
I've been working on a spreadsheet to help with reporting and I'm stumped on the final element. Essentially, if column G of a worksheet contains a certain text string, I want to copy the appropriate row to another worksheet under the existing data in that sheet.
After two hours of googling I've tried various solutions but haven't been able to configure one to do what I want it to. Currently I'm working with the below:
Dim x As Integer
Dim Thisvalue As String
Dim NextRow As Range
Sheets("Week 4").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column D
Thisvalue = Cells(x, 7).Value
If Thisvalue = "Customer placed on hold" Then
Cells(x, 1).Resize(1, 33).Copy
Sheets("Retained data").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Week 4").Select
End If
Next x
End Sub
However, I think I'm on the wrong track and in all honesty I've forgotten so much about VBA that I'm essentially starting from scratch again as far as my knowledge goes. Any help would be greatly appreciated!
The code below will loop throug all cells in Column G (until FinalRow), and check for value "Customer placed on hold". When it finds, it copies the entire row to the next avaialble row at "Retained data" worksheet.
Note: it's better to avoid using Select and ActiveSheet as they might change according to your current ActiveSheet. Instead it's better to use referenced Sheet objects, .Cells and Ranges.
Code
Option Explicit
Sub CopyRow()
Dim x As Long
Dim Thisvalue As String
Dim NextRow As Long
Dim FinalRow As Long
With Sheets("Week 4")
' Find the last row of data in Column A
FinalRow = .Cells(.Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column G
If .Cells(x, 7).Value = "Customer placed on hold" Then
' Find the last row of data
NextRow = Sheets("Retained data").Cells(Sheets("Retained data").Rows.Count, 1).End(xlUp).Row
' copy > paste in 1 line
.Cells(x, 7).EntireRow.Copy Sheets("Retained data").Range("A" & NextRow + 1)
End If
Next x
End With
End Sub
Try this one:
Sub Makro2()
Dim x As Integer
Dim Thisvalue As String
Sheets("Week 4").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
' Decide if to copy based on column D
Thisvalue = Cells(x, 7).Value
If Thisvalue = "Customer placed on hold" Then
Range(Cells(x, 1), Cells(x, 33)).Copy
With Sheets("Retained data")
.Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial xlPasteAll
End With
End If
Next x
End Sub
since you want to check column "G" values against a string ("Customer placed on hold") then you want to avoid looping through column "A" cells and loop through "string" cells of columns "G" only
then you can avoid looping through all cells and just Find() the wanted ones:
Sub CopyRow()
Dim firstAddress As String
Dim f As Range
With Worksheets("Week 4") '<--| reference your relevant worksheet
With .Range("G2", .Cells(.Rows.COUNT, "G").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through its column G "string" values only
Set f = .Find(what:="Customer placed on hold", lookat:=xlWhole, LookIn:=xlValues, after:=.Areas(.Areas.COUNT).Cells(.Areas(.Areas.COUNT).COUNT)) '<--| search for wanted string in referenced range, starting from the cell after its last cell (i.e.: the first cell)
If Not f Is Nothing Then '<--| if found
firstAddress = f.Address '<--| store its address to stop 'Find()' loop at its wrapping back to the first found cell
Do
With Worksheets("Retained data") '<--| reference target sheet
f.EntireRow.Copy .Cells(.Rows.COUNT, 1).End(xlUp).Offset(1) '<--| copy found cell entire row into last referenced worksheet first not empty cell
End With
Set f = .FindNext(f) '<--| find next cell matching wanted value
Loop While f.Address <> firstAddress '<--| exit loop when it wraps back to first found cell
End If
End With
End With
End Sub
should your column "G" data extend beyond actual range of column "A" data, and you be interested in limiting the range to this latter, then you just have to change:
With .Range("G2", .Cells(.Rows.COUNT, "G").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through its column G "string" values only
to
With Intersect(.Range("A2", .Cells(.Rows.COUNT, "A").End(xlUp)).EntireRow, .Range("G2", .Cells(.Rows.COUNT, "G").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues)) '<--| loop through its column G "string" values only down to its column "A" last not empty row
I want to clear all cells in my worksheet from first used to last used row in my selected column, but first I must know the first used row in my selected column. How can I find the first row in "X" column? (X may = {A, B, C, ...})
Try
firstUsedRow = Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
Where the second argument in Cells(1, 1) is the column number (e.g., A=1, B=2, etc.). Sheet1 is the worksheet name of the worksheet in question.
It is possible, though unlikely in your case, that the first row is row 1. In this case, the above code will actually select your last row of the used range. As a safety measure for this case, identify the last row and make sure your first row is either 1 or the row generated by the above code. So
finalRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").UsedRange.Rows.Count, 1).End(xlUp).Row
if finalRow = firstUsedRow then
firstUsedRow = 1
End If
All together
firstUsedRow = Worksheets("Sheet1").Cells(1, 1).End(xlDown).Row
finalRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").UsedRange.Rows.Count, 1).End(xlUp).Row
if finalRow = firstUsedRow then
firstUsedRow = 1
End If
Kindly see the code below. It will skip over all the blank rows in column A represented by second argument of Cells as 1. Then assign the row positions for variables firstRow and lastRow. Last clear the values from that range.
Sub ClearCells()
Dim i As Integer
Dim firstRow As Integer
Dim lastRow As Integer
i = 1
Do While Cells(i, 1) = ""
i = i + 1
Loop
firstRow = i
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(firstRow, 1), Cells(lastRow, 1)).ClearContents
End Sub
See below with no loop.
Sub ClearCells()
Dim firstRow As Integer
Dim lastRow As Integer
firstRow = Cells(1, 1).End(xlDown).Row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range(Cells(firstRow, 1), Cells(lastRow, 1)).ClearContents
End Sub
My question is: how to transpose the last four rows of the column G into different columns?
I usually use this static code:
Worksheets("Sheet8").Range("A1:A5").Copy
Worksheets("Sheet9").Range("A1").PasteSpecial Transpose:=True
But it doesn't allow me to stay on the same Sheet.
So I am trying to combine it with this code:
Dim r As Range, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Set r = Cells(N, 1).EntireRow
r.Copy
Cells(N + 1, 1).PasteSpecial Transpose:=True
r.Delete
Before
After
Any help is appreciated
Untested:
Dim c As Range, v
'find last-used cell in ColG
Set c = Cells(Rows.Count, "G").End(xlUp)
With c.offset(-3,0) 'starting with the cell 3 rows above the last-used cell...
v = .resize(4,1).value 'get the value of the 4-row/1-col range below
.resize(4,1).clearcontents '...then clear that range
.resize(1,4).value = Application.Transpose(v) 'place the values in a row
End with
I'm working on cleaning up timesheets for an Access database, and I'm having issues with cleaning up the data.
I have a time sheet with names in the first column, then all of the columns after that, from C to M (or so) have hours. What I am trying to accomplish is that when the Macro finds a name in the first column, it selects the columns in that row, finds the cells without hours, and fills them with zeroes
Dim r As Integer
Dim c As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Range(Cells(r, 3), Cells(r, 10)).Select
End If
Next
For Each c In Selection
If IsEmpty(c) Then
c.Value = 0
End If
Next
I'm attempting to loop and fill rows with zeroes based on the cell having a named entered in it. The problem that I'm running into is that cells are only being filled in the last name/row in the spreadsheet. The macro seems to be skipping over all but the last row.
I'm just learning VBA, so maybe I'm just missing something in the syntax.
Thanks for the help!
The problem is that you are moving on to the next selection, all the way to the last row, before you start filling in your 0s. Try this modification to your code:
Dim r As Integer
Dim c As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Range(Cells(r, 3), Cells(r, 10)).Select
End If
For Each c In Selection
If IsEmpty(c) Then
c.Value = 0
End If
Next c
Next r
Using this method, you fill in the 0s before moving on to the next selection/row.
Note: I avoid the use of .select/Selection because of the problems it can cause, so I am not sure if you will receive an error message if a row does not contain a name. If you wish to avoid this potential error, try the below:
Dim r As Integer
Dim c As Range
Dim c2 As Range
For r = 2 To 15 Step 1
If Cells(r, 1).Value <> "" Then
Set c2 = Range(Cells(r, 3), Cells(r, 10))
End If
For Each c In c2
If IsEmpty(c) Then
c.Value = 0
End If
Next c
Next r
By the way, did you strip out the Workbook and Sheet names from Range(Cells(r, 3), Cells(r, 10)) to simplify your post? I was surprised you were able to use that without errors. If so, you'd obviously have to put them back in for my code to work.
possibly,
Sub Button1_Click()
Dim Rws As Long, Rng As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(2, 1), Cells(Rws, 1)).SpecialCells(xlCellTypeConstants)
Rng = 0
End Sub
You want to take all of the blank cells and turn them into zeroes.
Sub zeroed_hours()
Dim rw As Long
With Sheets("Sheet1") '<-set this worksheet reference properly!
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If CBool(Len(.Cells(rw, 1))) Then 'found a name!
'C:M on this row
.Cells(rw, 3).Resize(1, 11).Replace what:="", replacement:=0, lookat:=xlWhole
End If
Next rw
End With
End Sub
This loops through the cells in column A. If it finds a value (something with length greater than zero) then it replaces all blank cells in C:M on that row with zeroes.