The pic shows what happens with my code.
I have a user form and I add the labels of the user form into the selected worksheet. And this is what I tried. Now the problem is why is it that there is one cell not on the same row as the others?
Dim c As Control
For Each c In Me.Controls
If TypeName(c) = "Label" Then
With ActiveSheet
i = i + 1
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If c <> "Chapter" Then
.Range(Cells(1, 1), Cells(1, i)).Name = "Chapter1"
.Range("Chapter1").Merge
.Range("Chapter1").Value = "Chapter 1"
.Range("Chapter1").HorizontalAlignment = xlCenter
.Cells(lastRow, i).Value = c.Caption
End If
End With
End If
Next
The problem is that the first time you do .Cells(.Rows.Count, 1).End(xlUp).Row there will not be anything yet in A2, so lastRow will be 1. But once you put the value "No." in that cell the next time you execute that code (with i being 2), A2 will be filled, so now .Cells(.Rows.Count, 1).End(xlUp).Row will return 2, giving you the effect you get: all other values end up one row lower.
There are several way to solve this, but here is one way. Add + IIf(i = 1, 1, 0) the assignment of lastRow:
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row + IIf(i = 1, 1, 0)
Related
Help me to add loop to below code. As of now code copies only first match from text in cell -"26002354". I want it to copy all matches from one cell and than it goes to next cell down.
Lets say - in text i have tree matches(all text in one cell):
26002354
26008541
26009841
All of them i need to get in a row on the right.
Sub extract()
Dim r As Long, dashpos As Long, m As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
m = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For r = 2 To m
dashpos = InStr(1, Cells(r, 1), "2600")
Cells(r, 2).Value = Mid(Cells(r, 1), dashpos, 14)
Cells(r, 3).Value = Mid(Cells(r, 1), dashpos, 14)
Cells(r, 4).Value = Mid(Cells(r, 1), dashpos, 14)
Next
End Sub
Your intended result is a little unclear but to get three 8 digit numbers in columns B:D from columns A containing '26002354 26008541 26009841', use Split.
Sub extract()
Dim r As Long
with Worksheets("Sheet1")
For r = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(r, 2).resize(1, 3) = split(Cells(r, 1).value2, chr(32))
Next
end with
End Sub
I want to consolidate two worksheets on the basis of a "Register No." in a third worksheet.
Workbook:
Tabelle1: Consolidated Worksheet //
Tabelle2: Input Data1 //
Tabelle3: Input Data2
Notes:
At first the "Register No." can only be found in Tabelle2 & Tabelle3 in column A.
Because Tabelle1 has also a different column sequence than Tabelle2 & Tabelle3 I am using vLookup to paste the data to the right columns in Tabelle1.
Idea:
1. Step
Pasting Tabelle2 Data, including "Register No.", to the right columns in Tabelle1 via vLookup. Note: This means "Register No." to Tabelle 1 column A.
2. Step
Pasting Tabelle3 Data to right rows and columns in Tabelle1 via vLookup.
As Tabelle3 contains more "Register No." than Tabelle2, I want my code to check the "Register No." in Tabelle1 column A and copy the corresponding data from Tabelle3.
ERROR:
The 2. Step is not working.
Runtime-Error '1004'
For example:
For i = 2 To lastrow2
Tabelle1.Cells(7 + i, 2) = Application.WorksheetFunction.VLookup(Tabelle1.Cells(i, 1), myrange2, 2, False)
Next i
Does anyone know what is wrong with my code? Thanks a lot :)
My Code:
Sub ConsolidateData()
Dim lastrow As Long
lastrow = Tabelle2.Range("A" & Rows.Count).End(xlUp).Row
Set myrange = Tabelle2.UsedRange
For i = 2 To lastrow
Tabelle1.Cells(7 + i, 1) = Application.WorksheetFunction.VLookup(Tabelle2.Cells(i, 1), myrange, 1, False)
Next i
For i = 2 To lastrow
Tabelle1.Cells(7 + i, 3) = Application.WorksheetFunction.VLookup(Tabelle2.Cells(i, 1), myrange, 2, False)
Next i
For i = 2 To lastrow
Tabelle1.Cells(7 + i, 6) = Application.WorksheetFunction.VLookup(Tabelle2.Cells(i, 1), myrange, 3, False)
Next i
Dim lastrow2 As Long
lastrow2 = Tabelle3.Range("A" & Rows.Count).End(xlUp).Row
Set myrange2 = Tabelle3.UsedRange
For i = 2 To lastrow2
Tabelle1.Cells(7 + i, 2) = Application.WorksheetFunction.VLookup(Tabelle1.Cells(i, 1), myrange2, 2, False)
Next i
For i = 2 To lastrow2
Tabelle1.Cells(7 + i, 4) = Application.WorksheetFunction.VLookup(Tabelle1.Cells(i, 1), myrange2, 3, False)
Next i
For i = 2 To lastrow2
Tabelle1.Cells(7 + i, 5) = Application.WorksheetFunction.VLookup(Tabelle1.Cells(i, 1), myrange2, 4, False)
Next i
For i = 2 To lastrow2
Tabelle1.Cells(7 + i, 7) = Application.WorksheetFunction.VLookup(Tabelle1.Cells(i, 1), myrange2, 5, False)
Next i
End Sub
I think the problem is the way you are referencing your worksheets. You are using the Worksheet.CodeName vs the Worksheet.Name of the worksheet.
Look at my example below and you will see that the Worksheet.CodeName and Worksheet.Name do not match.
Worksheet.CodeName is the 1st part of the name and Worksheet.Name is what's shown in parentheses. Therefore the Worksheet.CodeName for the second worksheet is Sheet5, whereas the Worksheet.Name is Sheet6.
This is because I deleted a worksheet and excel, behind the scenes, renamed the Worksheet.CodeName reference.
To use what you see when looking at the tabs in the workbook you need to reference it by Worksheet.Name, not Worksheet.CodeName.
Sub testPickingWorksheets()
' This code fails
a = Sheet6.Range("A1").Value
MsgBox (a)
' This code works
a = Worksheets("Sheet6").Range("A1").Value
MsgBox (a)
End Sub
As you can see from the code above, you need to use the Worksheets() Ojbect with the Worksheet.Name in "quotes" instead of directly referencing the Worksheet.CodeName.
I have the below code that pulls out specific data from the spreadsheet and formats it into a table. Both for loops work, however the first one will only work if I'm on Sheet1 and the second one will only work if I'm on Sheet2.
I can't work out how to rewrite it to make both sections of code work anywhere in the spreadsheet. Preferably from Sheet1 if it had to be.
Sub MakeMyTable()
Dim Col As Variant
Dim Col2 As Variant
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "D"
Col2 = "A"
StartRow = 1
X = 3
'This with pulls the formatted data into totals into Sheet2
With Sheets("Sheet1")
LastRow2 = Cells(Rows.Count, Col).End(xlUp).Row
For R = StartRow + 1 To LastRow2 + 1 Step 1
If .Cells(R, Col) = "" Then
Sheets("Sheet2").Cells(1, "A").Value = "Project Cost Centers Costs At " & Date
Sheets("Sheet2").Cells(X, "A").Value = .Cells(R - 1, Col).Value
Sheets("Sheet2").Cells(X, "B").Value = .Cells(R - 1, "F").Value
Sheets("Sheet2").Cells(X, "C").Value = .Cells(R, "P").Value
Sheets("Sheet2").Cells(X, "C").NumberFormat = "$#,##0.00"
X = X + 1
End If
Next R
End With
' This with finds any cell that has "RX04F.029.038" in it and moves it to the
' bottom of the table.
With Sheets("Sheet2")
LastRow2 = Cells(Rows.Count, Col2).End(xlUp).Row
For R = LastRow2 To StartRow + 2 Step -1
If InStr(1, Cells(R, Col2).Value, "RX04F.029.038") > 0 Then
Rows(R).Cut
Rows(LastRow2 + 1).Insert Shift:=xlDown
R = R + 1
LastRow2 = LastRow2 - 1
End If
Next R
End With
End Sub
You also need to properly link your With statement to the ranges you use. For example, you have With Sheets("Sheet2") but them don't link the lastRow2 = Cells().Row to it. Do this for all such instances: LastRow2 = .Cells(.Rows.Count,Col2).End(xlUp).Row. Otherwise, any use of a range will occur on the ActiveSheet, whatever that may be. – BruceWayne 3 mins ago
Edit: BruceWayne gave me the answer I need in the comments but cant mark it as an answer so this is the best I could do. Thank you
You can change the sheet names to what you want.
Or you can swap:
With Sheets("Sheet1")
for
With ActiveSheet
if you want to run the loops on the active sheet.
My code works below works but I'd like to add one function. I've got a large data sheet with each line repeated three times. Within each set of three I've added a month twice. The purpose is to smooth out forecasted sales into one month and two months beyond the estimated shipping date. Now I'd like to multiply my the values in column E by factors into column F. The original line in each set of three will =50%*E:E in column F, the second line will have =30%*E:E in column F, and the third line will have =20%*E:E in Column F. This process should be repeated continually for every set of three lines. Problem: My current code does give me the correct value, however the values are two cells lower than they need to be. Thanks for any help in advance! My current code is below:
Public Sub DateAdd()
Dim r As Long
Dim l As Long
Dim Quant As Long
Dim dttTemp As Date
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("SalesForce Projects")
Application.ScreenUpdating = False
For r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row To 1 Step -1
With ws.Cells(r, 1).EntireRow
.Copy
.Resize(2).Offset(1, 0).Insert Shift:=xlDown
End With
dttTemp = ws.Cells(r, "S").Value
ws.Cells(r + 1, "S").Value = DateSerial(Year(dttTemp), Month(dttTemp) + 1,
Day(dttTemp))
ws.Cells(r + 2, "S").Value = DateSerial(Year(dttTemp), Month(dttTemp) + 2,
Day(dttTemp))
Next r
Application.ScreenUpdating = True
' This is where my code is bad
For l = ws.Range("A" & ws.Rows.Count).End(xlUp).Row To 1 Step -3
Quant = ws.Cells(l, "E").Value
ws.Cells(l, "F").Value = Cells(l, "E") * 0.5
ws.Cells(l + 1, "F").Value = Cells(l, "E") * 0.3
ws.Cells(l + 2, "F").Value = Cells(l, "E") * 0.2
Next l
End Sub
Why not do it in the first loop like below?
Public Sub DateAdd()
Dim r As Long
Dim l As Long
Dim Quant As Long
Dim dttTemp As Date
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("SalesForce Projects")
Application.ScreenUpdating = False
For r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row To 1 Step -1
With ws.Cells(r, 1).EntireRow
.Copy
.Resize(2).Offset(1, 0).Insert Shift:=xlDown
End With
dttTemp = ws.Cells(r, "S").Value
ws.Cells(r, "F").Value = Cells(r, "E") * 0.5 '\\ First line
ws.Cells(r + 1, "S").Value = DateSerial(Year(dttTemp), Month(dttTemp) + 1, Day(dttTemp))
ws.Cells(r + 1, "F").Value = Cells(r, "E") * 0.3 '\\ Second line
ws.Cells(r + 2, "S").Value = DateSerial(Year(dttTemp), Month(dttTemp) + 2, Day(dttTemp))
ws.Cells(r + 2, "F").Value = Cells(r, "E") * 0.2 '\\ Third line
Next r
Application.ScreenUpdating = True
End Sub
When you say "50% of the value in column E," you could mean the entire value of all 90 in column E or just the value of the three cells in a set. If you mean the first then (I assume that row 1 is headings, so your values start at row 2.) In cell F2 enter the formula
=Sum(E:E)*.5
In cell F3 enter
=SUM(E:E)*.3
In cell F4 enter
=SUM(E:E)*.2
If you mean the other option then enter:
In F2 =Sum(E2:E4)*.5
in F3 =Sum(E2:E4)*.3
In F4 =Sum(E2:e4)*.2
Now select f2:f4. Place your mouse on the bottom right corner and you should see the cursor change to a small black cross. Double-click and the formulas will be replicated down the sheet. If you have more than one sheet to fill then control click on the tab names before starting this process to similtainoiusly copy to all selected sheets.
In this case there is no need to loop backwards. Update the For statement to the following:
For l = 1 to ws.Range("A" & ws.Rows.Count).End(xlUp).Row Step 3
Then it should produce desired results.
I have an Excel sheet with cells in some columns merged:
I need to normalize it, such that the cells in the first column are unmerged (those should be considered the true "rows"), but such that unmerged groups of cells (in these "rows") are put into a single cell with newlines to retain the list-like content:
Note that in some columns besides the first, there may also be some merged cells, but in any case the first column should determine what a "row" in the output sheet should look like.
Does such a VBA script exist to do this?
UPDATE: Here's a little pseudo-code for what I was thinking:
foreach row:
determine height of merged cell in column A
unmerge cell in column A (content is in top cell of range?)
for each column after A:
if cell is merged, unmerge (content is in top cell of range?)
else concatenate cell contents with newline separator in top cell of row range
cleanup excess rows from the unmerging
Unfortunately I think there's a bit of complexity in some of these steps.
UPDATE#2: Based on the accepted answer, I created some new code to accomplish my goals:
Sub dlo()
Dim LastRow&, r&, c&, rowheight&, n&, Content$, NewText$
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To LastRow
If Cells(r, 1).MergeCells Then
rowheight = Cells(r, 1).MergeArea.Cells.Count
For c = 1 To LastCol
NewText = vbNullString
For rr = r To (r + rowheight - 1)
Content = Cells(rr, c)
Cells(rr, c) = vbNullString
NewText = NewText & vbCrLf & Content
Next
Cells(r, c).UnMerge
Cells(r, c) = NewText
Next
'Cells(i + 1, 1).Resize(k - 1, 2).Delete Shift:=xlUp
'LastRow = LastRow - rowheight + 1
End If
DoEvents
Next
Application.DisplayAlerts = True
End Sub
The only thing I didn't finish was the deletion of resulting blank rows (I ended up just commenting those out since I knew a could just sort the table to eliminate the blanks).
If anyone has better ideas for how to describe this, please let me know so I can edit the title... I have a feeling this is not a rare need, so I'd like to help other find this.
Is this what you asking for?
Sub dlo()
Dim LastRow&, i&, j&, k&, n&, Content$, Text$
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Do
i = i + 1
Text = vbNullString
If Cells(i, 1).MergeCells Then
k = Cells(i, 1).MergeArea.Cells.Count
n = Cells(i, 1).RowHeight
For j = 1 To k
Content = Cells(j + i - 1, 2)
Cells(j + i - 1, 2) = vbNullString
Text = Text & vbCrLf & Content
Next
Cells(i, 1).UnMerge
Cells(i, 2) = Mid(Text, 3)
Cells(i + 1, 1).Resize(k - 1, 2).Delete Shift:=xlUp
Rows(i).RowHeight = n * k
NewLastRow = LastRow - k + 1
End If
DoEvents
Loop Until i = NewLastRow
Application.DisplayAlerts = True
End Sub
The above code works fine to my dummy data.