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
Related
I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft
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
In the code below, my LastRow variable is not storing the right row number on the 27th loop (i = 27) causing the code to malfunction
I have used the F8 step through multiple times and noticed that the issue is on the 27th loop. The LastRow variable is meant to be +1204 rows from the previous LastRow value on each iteration of the loop, so I was expecting LastRow = 32509 instead of LastRow = 31316. For reference, on the 26th loop, LastRow = 31305. I'm not sure why the it is finding the wrong LastRow when the code has worked for the first 26 loops.
I am trying to get from my Source Table to my Desired Table:
Source Table
to
Desired Table
Also , the final error that shows is:
Run-Time error '1004': Application -defined or object- defined error
Sub Populate_entity()
Dim i As Integer
i = 1
Dim LastRow As Long
Dim SearchText As String
Do While i < 122 ' go across entity (columns wise)
If i = 1 Then
Range("E1").Select
Selection.Copy
SearchText = ActiveCell.Value
ActiveCell.End(xlToLeft).Select 'snap to left (cell A1)
ActiveCell.Offset(0, 2).Select 'move to cell C1
ActiveCell.Offset(1, 0).Select ' move to cell C2
Else
ActiveCell.Offset(0, i + 1).Select
Selection.Copy
SearchText = ActiveCell.Value
ActiveCell.End(xlToLeft).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
End If
ActiveSheet.Paste
ActiveCell.Offset(1203, 0).Select
ActiveSheet.Paste
ActiveCell.End(xlUp).Select
' ======== Error here ========
LastRow = Cells.Find(What:=SearchText, After:=ActiveCell, LookIn:=xlValues, SearchOrder:=xlByRows).Row
Range("C" & ActiveCell.Row & ":C" & LastRow).FillDown
ActiveCell.End(xlUp).Select
i = i + 1
Loop
End Sub
A summary of what you want, as you described in the comments:
Copy the values from cells E1:DU1, paste each cell 1204 times in column C.
1st loop it will paste cell E1 in C2:C1205
2nd loop it will paste cell F1 to C1206:C2409
etc.
This code achieves that:
Sub Populate_entity()
' Declare 2 range variables (top row to copy from and paste destination)
Dim RowRange As Range
Dim PasteCells As Range
' Use the With block to specify the sheet. If you want the destination
' to be another sheet, then you can specify that instead:
' ThisWorkbook.Sheets("SheetName").Range("...")
With ThisWorkbook.ActiveSheet
Set RowRange = .Range("E1:DU1") ' Set range to copy from
Set PasteCells = .Range("C2:C1205") ' Set paste cells, blocks of 1204 cells in column C
End With
' Loop through RowRange, copy each cell's value into PasteCells
' Then offset the PasteCells range by 1024 rows, so next RowRange cell
' is inserted underneath previously copied cells.
Dim ofst As Long
For ofst = 1 To RowRange.Cells.Count
' Use .Value to avoid the (comparably slow) copy/paste operation
PasteCells.Offset((ofst - 1) * 1204, 0).Value = RowRange.Cells(ofst).Value
Next ofst
End Sub
In my opinion you don't need any search because your code always places the SearchString in row 1205. Since you know that it is there you don't need to look for it. This thought brings me to the code below.
Sub Populate_Entity()
Dim C As Long ' Column
Dim Target As Range
Dim FirstRow As Long
Dim LastRow As Long
FirstRow = 2
LastRow = 7 '1205
C = 3
Range("C2").value = Range("E1").value
' Cells(2, C).Value = Cells(1, 5).Value
Do
Set Target = Range(Cells(FirstRow, C), Cells(LastRow, C))
Target.FillDown
C = C + 1
Cells(2, C).value = "Can't figure"
Loop While C < 3 ' 122
End Sub
I have cut the loop short to only 7 rows (instead of 1205) and 3 columns (instead of 122). I just couldn't figure out where the text in the FirstRow should come from. For column C it comes from E1, but where does it come from in the subsequent columns? You can fill this in using the method I showed you above, like, Cells(2, C).Value = Cells(1, 5).Value. I believe that the 5 can be replaced by a value derived from the current C, perhaps C + 2.
Note the Cells(2, C).Value doesn't refer to the value in cell C2. Instead if refers to the cell in Row 2, Column C.
I am trying to get data from an Excel sheet. If the date indicated on the column header is today's date then contents of that column need to be copied. After checking all the columns, the final data needs to be pasted in another sheet.
I have built a macro to get stock prices from web. Now I need to filter the data based on date to make it ready for making graphs. I have tried multiple variations of the below code but till now no success. Copying the ranges is the problem area.
Sub graphs()
Dim d As Date
Dim a As Variant
Dim f As Variant
Dim b As Variant
Dim x As Variant
Dim col As Variant
Dim r As Range
Dim j As Range
r = ThisWorkbook.Sheets("historic price").Range(Cells(1, 1), Cells(50, 1)) ' this is to copy the first column with company names
b = WorksheetFunction.CountA(Rows(1))
For x = 2 To b
a = ThisWorkbook.Sheets("historic price").Cells(1, x) ' below 3 lines are to extract date from column header
f = WorksheetFunction.Search(" ", a, 10)
d = Mid(a, 10, (f - 10))
If d = Date Then
r = Union(r, Range(Cells(1, x), Cells(50, x))) ' this is to add data to r
End If
Next x
col = r.Columns.Count ' count number of columns stored in r
r.Copy
Worksheets("graphs").Activate
Set j = ThisWorkbook.Sheets("Graphs").Range(Cells(1, 1), Cells(50, col))
j.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False
ThisWorkbook.Sheets("Graphs").Cells(1, 1).Select
End Sub
You need to set the new range
For example
Set rng1 = .Range("A1")
Set rng2 = .Range("A2")
Set NewRng = .Range(rng1.Address & ":" & rng2.Address)
or
Set newRng = Union(rng1, rng2)
So you need to set r
set r = Union(r, Range(Cells(1, x), Cells(50, x)))
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: