My code concatenates the values of the columns of the first row of table "Data" and writes the result in table "Insert" cell A1.
The error is that the concatenation result of next row is added at the end of the first result in table "Insert" A1 and so on. The results should be written in table "Insert" in column A row by row too.
What is wrong with my code?
Sub InsertStatementRow()
Dim x As String
Dim rng As Range
Dim cel As Range
Dim ColMax As Integer
Dim i As Long
Sheets("Data").Select
ColMax = Cells(1, Columns.Count).End(xlToLeft).Column
row = 1
Do While Cells(row, "A").Value <> ""
With Worksheets("Data")
i = 1
Set rng = Range(.Cells(i, 1), .Cells(i, ColMax))
End With
For Each cel In rng
x = x & cel.Value
Next
Sheets("Insert").Cells(i, 1).Value = x
row = row + 1
Loop
End Sub
Thanks for your help!
i is being set as "1" each time the Do While loop begins, so the rng variable will always refer to row 1 of the Data worksheet. It's also copying to row 1 on the Insert worksheet. Change the i to row and it should work:
Do While Cells(row, "A").Value <> ""
With Worksheets("Data")
Set rng = Range(.Cells(row, 1), .Cells(row, ColMax))
End With
x = ""
For Each cel In rng
x = x & cel.Value
Next
Sheets("Insert").Cells(row, 1).Value = x
row = row + 1
Loop
you set
i=1
before
Set rng = Range(.Cells(i, 1), .Cells(i, ColMax))
but you seem to bee working with variable row. So delete/comment the line i=1 and change Set rng
Set rng = Range(.Cells(row, 1), .Cells(row, ColMax))
hope it solves your problem.
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub
Hello I am trying to copy a range into a single column. The range is a mix of blank cells and cells with values.I only want to copy and paste the cells with values and I would it to find the first blank cell and want it to walk itself down the column from there.
The code I have right now (besides taking forever) pastes in the first row.
Dim i As Integer
i = 1
ThisWorkbook.Worksheets("amount date").Select
For Row = 51 To 100
For col = 2 To 1000
If Cells(Row, col).Value <> "" Then
Cells(Row, col).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
End If
Next
Next
Do While Worksheets("sheet 2").Range("G" & i).Value <> ""
i = i + 1
Loop
End Sub
This will work:
Sub qwerty()
Dim i As Long, r As Long, c As Long
i = 1
ThisWorkbook.Worksheets("amount date").Select
For r = 51 To 100
For c = 2 To 1000
If Cells(r, c).Value <> "" Then
Cells(r, c).Copy
Worksheets("sheet 2").Range("G" & i).PasteSpecial xlPasteValues
i = i + 1
End If
Next
Next
End Sub
Perhaps this will be a little faster (even though it seems to have been slow arriving).
Sub CopyRangeToSingleColumn()
' 20 Oct 2017
Dim LastRow As Long
Dim LastClm As Long
Dim Rng As Range, Cell As Range
Dim CellVal As Variant
Dim Spike(), i As Long
With ThisWorkbook.Worksheets("amount date")
With .UsedRange.Cells(.UsedRange.Cells.Count)
LastRow = Application.Max(Application.Min(.Row, 100), 51)
LastClm = .Column
End With
Set Rng = .Range(.Cells(51, "A"), .Cells(LastRow, LastClm))
End With
ReDim Spike(Rng.Cells.Count)
For Each Cell In Rng
CellVal = Trim(Cell.Value) ' try to access the sheet less often
If CellVal <> "" Then
Spike(i) = CellVal
i = i + 1
End If
Next Cell
If i Then
ReDim Preserve Spike(i)
With Worksheets("sheet 2")
LastRow = Application.Max(.Cells(.Rows.Count, "G").End(xlUp).Row, 2)
.Cells(LastRow, "G").Resize(UBound(Spike)).Value = Application.Transpose(Spike)
End With
End If
End Sub
The above code was modified to append the result to column G instead of over-writing existing cell values.
Do you need copy the whole row into one cell, row by row? For each loop shall be faster. I guess, this should work
Sub RowToCell()
Dim rng As Range
Dim rRow As Range
Dim rRowNB As Range
Dim cl As Range
Dim sVal As String
Set rng = Worksheets("Sheet3").Range("$B$51:$ALN$100") 'check this range
For Each rRow In rng.Rows
On Error Resume Next
Set rRowNB = rRow.SpecialCells(xlCellTypeConstants)
Set rRowNB = Union(rRow.SpecialCells(xlCellTypeFormulas), rRow)
On Error GoTo 0
For Each cl In rRowNB.Cells
sVal = sVal & cl.Value
Next cl
Worksheets("sheet4").Range("G" & rRow.Row - 50).Value = sVal
sVal = ""
Next rRow
End Sub
its quick for this range.
I have a macro that consolidate the values on another sheet, and based on these values, it´s has to go back on the first sheet and delete.
The sheet it´s like this, if the value on the G2 it´s (Manter a linha), it´s get the number of the row on the F2, and goes to delete the previews of the row.
Else, goes to I2, and do the same.
Thank you for your help and time.
Sheet
I have this so far:
Sub Delete()
Range("G2").Select
Do Until IsEmpty(ActiveCell)
Range("G" & Rows.Count).Select
If Range("G" & 2).Value = ("<<<Manter a linha") Then
Sheets("Controle Estoque Fixo").Select
Rows("2:5").Select
Selection.EntireRow.Delete
End If
Loop
EDIT:
Dim r1 As Range, c As Range
Dim s As String
Dim v As String
Dim k As String
Dim t As String
k = "1"
Set r1 = Range(Cells(2, "H"), Cells(Rows.Count, "H").End(xlUp))
v = Sheets("Analise de Estoque").Cells(2, "G").Value
For Each c In r1
If c.Text = ("<<<Manter a linha") Then
Sheets("Controle Estoque Fixo").Select
t = (v - 1)
Rows(t).Select.Clear
End If
Next
End Sub
Now I can go back and select the value of the cell that contains the row, that I want to keep, so I add a "- 1" to select before that, but I tried to add the begging and won´t work(tried to add T as a string and put = 1)
You need to build your range and delete all the rows at once.
Sub DeleteMatches()
Dim r1 As Range, c As Range
Dim s As String
Set r1 = Range(Cells(2, "G"), Cells(Rows.Count, "G").End(xlUp))
For Each c In r1
If c = "<<<Manter a linha" Then
If Len(s) Then s = s & ","
s = s & "A" & c.Offset(0, -1)
End If
Next
If Len(s) Then
s = Left(s, Len(s) - 1)
Sheets("Controle Estoque Fixo").Range(s).EntireRow.Delete
End If
End Sub
If you only want to clear the rows and not delete then them then you can do it your way.
Sub DeleteMatches2()
Dim r1 As Range, c As Range
Dim t As String
With Sheets("Analise de Estoque")
Set r1 = .Range(.Cells(2, "H"), .Cells(Rows.Count, "H").End(xlUp))
End With
For Each c In r1
If c.Text = "<<<Manter a linha" Then
Sheets("Controle Estoque Fixo").Select
t = c.Offset(0, -1)
Rows(t).ClearContents
End If
Next
End Sub
Sub DeleteMatches3()
Dim r1 As Range, c As Range
Dim i As Long, LastRow As Long
Dim t As String
With Sheets("Analise de Estoque")
LastRow = .Cells(Rows.Count, "H").End(xlUp)
For i = 2 To LastRow
If .Cells(i, "G").Text = "<<<Manter a linha" Then
t = .Cells(i, "F").Text
Sheets("Controle Estoque Fixo").Rows(t).ClearContents
End If
Next
End With
End Sub
Just remember that when you delete rows you have to go from the last row to the first
For i = LastRow To 2 Step - 1
Next
I have a problem with a specific excel task. Although I searched the web thoroughly for tips and parts of code I could use, I was not able to get near a functioning solution.
This is my problem:
I have around 30 Worksheets with two columns each.
The number of Rows varies from WS to WS but the two columns on each sheet are equally long.
The first column of each Sheet contains minimum values and the second column holds the respective maximum values.
E.g.
| A | B
1 | 1000 | 1010
2 | 2020 | 2025
Now I need one single column with all values from these intervals including the Max and Min values.
Preferred solution in Column C:
1000, 1001, 1002, 1003, 1004, 1005, 1006, 1007, 1008, 1009, 1010, 2020, 2021, 2022, 2023, 2024, 2025
I thought of highlighting the two columns and then activating a macro to generate the list. I would then repeat this process for each WS manually. Some sheets have only 4 to 20 rows but some have over 7000 rows.
And if it helps anything: The numbers are postcodes ;-)
I'd be very grateful for any kind of help.
Thanks in advance!
Try this:
Sub Test()
Dim LastRow As Long, ColIndex As Long
Dim i As Long, j As Long
Dim min As Long, max As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ColIndex = 1
For i = 1 To LastRow
min = ws.Cells(i, 1).Value
max = ws.Cells(i, 2).Value
For j = min To max
ws.Cells(ColIndex, 3).Value = j
ColIndex = ColIndex + 1
Next j
Next i
Next ws
End Sub
edited: to have one big string in column "C" (added two lines in each code)
edited 2: added "zip3" solution for having all values listed in "C" column only
you could use either following ways
Option Explicit
Sub zips3()
'list values in column "C" in sequence from all min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
With cell.End(xlToRight).Offset(, 2).Resize(, cell.Offset(, 1).Value - cell.Value + 1)
.FormulaR1C1 = "=RC1+COLUMN()-4"
sht.Range("C" & sht.Cells(sht.Rows.Count, "C").End(xlUp).Row).Offset(1).Resize(.Columns.Count) = Application.Transpose(.Value)
.ClearContents
End With
Next cell
If IsEmpty(sht.Range("C1")) Then sht.Range("C1").Delete (xlShiftUp)
Next sht
End Sub
Sub zips()
'list values in column "C" from corresponding min to max in columns "A" and "B"
Dim sht As Worksheet
Dim cell As Range
Dim j As Long
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
For j = cell.Value To cell.Offset(, 1).Value
cell.End(xlToRight).Offset(, 1) = j
Next j
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
Sub zips2()
Dim sht As Worksheet
Dim cell As Range
For Each sht In ThisWorkbook.Sheets
For Each cell In sht.Range("A1:A" & sht.Cells(sht.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlNumbers)
cell.End(xlToRight).Offset(, 1).Resize(, cell.Offset(, 1).Value - cell.Value + 1).FormulaR1C1 = "=RC1+COLUMN()-3"
'lines added to have one bg string in column "C"
cell.Offset(, 2).Value2 = "'" & Join(Application.Transpose(Application.Transpose(Range(cell.Offset(, 2), cell.Offset(, 2).End(xlToRight)))), ",")
Range(cell.Offset(, 3), cell.Offset(, 3).End(xlToRight)).ClearContents
Next cell
Next sht
End Sub
A solution you can use as you like would be kinda like this:
Public Function getZIPs(rng As Range) As String
Dim myVal As Variant, str As String, i As Long, j As Long
myVal = Intersect(rng, rng.Parent.UsedRange).Value
For i = 1 To UBound(myVal)
If IsNumeric(myVal(i, 1)) And IsNumeric(myVal(i, 2)) And Len(myVal(i, 1)) > 0 And Len(myVal(i, 2)) > 0 Then
If myVal(i, 1) <= myVal(i, 2) Then
For j = myVal(i, 1) To myVal(i, 2)
str = str & ", " & j
Next
End If
End If
Next
getZIPs = Mid(str, 3)
End Function
Put this into a module and then either go for C1: =getZIPs(A1:B1) and auto fill down or directly =getZIPs(A:B) to get all numbers in one cell or use it in a sub to do it automatically.
If you have any questions, just ask :)
EDIT:
If you want it all exactly in the one-column-way, you can use this (should be fast):
Sub getMyList()
Dim sCell As Range, gCell As Range
Set gCell = ActiveSheet.[A1:B1]
Set sCell = ActiveSheet.[C1]
Dim sList As Variant
While IsNumeric(gCell(1)) And IsNumeric(gCell(2)) And Len(gCell(1)) > 0 And Len(gCell(2)) > 0
If gCell(1) = gCell(2) Then
sCell.Value = gCell(1)
Set sCell = sCell.Offset(1)
Else
sList = Evaluate("ROW(" & gCell(1) & ":" & gCell(2) & ")")
sCell.Resize(UBound(sList)).Value = sList
Set sCell = sCell.Offset(UBound(sList))
End If
Set gCell = gCell.Offset(1)
Wend
End Sub
If you have any questions, just ask ;)
I want to copy data from one sheet to another with few conditions:
1. Start with row 1 and column 1 and match if the R1 C2 is not empty then copy the pair R1 C1 and R1 C2 and paste into the other sheet as a new row.
increment the counter for column and match R1 C1 with R1 C3 and so on.
increment the Row when the column counter reaches 10.
I tried the below code but gives compile error as Sub or function not defined.
Please help.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 2
y = 2
Do While Cells(x, 1) <> ""
If Cells(x, y) <> "" Then
Worksheets("Sheet1").Cells(x, 2).Copy
Worksheets("Sheet2").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
Worksheets("Sheet1").Activate
y = y + 1
If y = 10 Then x = x + 1
End If
Loop
End Sub
You are geting that error because of > in Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
Avoid the use of using Integer when you are working with rows. Post excel2007, the row count has increased and the Integer may not be able to handle the row number.
Avoid the use of .Activate.
Is this what you are trying? (Untested)
Note: I am demonstrating and hence I am working with the excel cells directly. But in reality, I would be using autofilter & arrays to perform this operation.
Private Sub CommandButton1_Click()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRowInput As Long, lRowOutput As Long
Dim i As Long, j As Long
Set wsInput = ThisWorkbook.Worksheets("Sheet1")
Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
With wsInput
lRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRowInput
If .Cells(i, 2).Value <> "" Then
For j = 3 To 10
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
.Range(.Range(.Cells(i, 1), .Cells(i, 1)).Address & _
"," & _
.Range(.Cells(i, j), .Cells(i, j)).Address).Copy _
wsOutput.Range("A" & lRowOutput)
Next j
End If
Next i
End With
End Sub