I've got a workbook with one "source" worksheet and several destination sheets. essentially the source sheet contains information that I need to match and split out to team members. I've got the following code that freezes excel on me like it's stuck in a never ending loop. the VBA exists on the source worksheet's VBA.
Sub SearchForString()
Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim z as Integer
x = 1
y = 1
z = 4 'in this case we are looking at column D as the last non-criteria column
For Each ws In Worksheets(Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6", "Sheet7"))
x = 1 'setting back to row 1 to grab headers
y = 1
ws.UsedRange.ClearContents
Worksheets(ws.Name).Cells(y, 1) = Cells(x, 1)
Worksheets(ws.Name).Cells(y, 1).Font.Bold = True
Worksheets(ws.Name).Cells(y, 2) = Cells(x, 2)
Worksheets(ws.Name).Cells(y, 2).Font.Bold = True
Worksheets(ws.Name).Cells(y, 3) = Cells(x, 3)
Worksheets(ws.Name).Cells(y, 3).Font.Bold = True
Worksheets(ws.Name).Cells(y, 4) = Cells(x, 4)
Worksheets(ws.Name).Cells(y, 4).Font.Bold = True
'begin the copy loop
x = 2 'setting forward to the first row to start evaluating for copy
y = 2
z = z + 1 'increments along the columns we are matching in the array
Do while Cells(x, 1) <> vbNullString 'make sure we have an active row
If Cells(x, z) = "Yes" Then ' looks for row plus column for match
Do While Worksheets(ws.Name).Cells(y, 2) <> vbNullString
y = y + 1 'setting the row to start pasting
Loop
Worksheets(ws.Name).Cells(y, 1) = Cells(x, 1)
Worksheets(ws.Name).Cells(y, 2) = Cells(x, 2)
Worksheets(ws.Name).Cells(y, 3) = Cells(x, 3)
Worksheets(ws.Name).Cells(y, 4) = Cells(x, 4)
x = x + 1 'increment to next row
End If
Loop
Next ws
End Sub
I can't spot what would be sticking it into an endless loop like it seems to be in. Is anything glaring to anyone?
If Cells(x, z) <> "Yes", x never gets incremented and Cells(x, 1) <> vbNullString stays true
Related
I successfully wrote a code that sort through a database and looks for parts that need to be made by waterjet technique. Then, copy the associated lines with the waterjet criteria met, to another sheet named "Waterjet". It works fine, but the picture on the source sheet are not copied to the second sheet. I want to get help in finding why the pictures are not follow the cell. I checked and verified that the pictures are set to move and sized by the the cell.
Here is the code:
Sub Worksheet_Activate()
Range("A4:K2000").Select
Selection.ClearContents
Range("D1").Select
i = 4
j = 4
While i <= 2000
If Worksheets("Sheet1").Cells(i, 7) = "Waterjet" Then
p = Worksheets("Sheet1").Cells(i, 1)
q = Worksheets("Sheet1").Cells(i, 2)
r = Worksheets("Sheet1").Cells(i, 3)
s = Worksheets("Sheet1").Cells(i, 4)
t = Worksheets("Sheet1").Cells(i, 5)
u = Worksheets("Sheet1").Cells(i, 6)
v = Worksheets("Sheet1").Cells(i, 7)
w = Worksheets("Sheet1").Cells(i, 8)
x = Worksheets("Sheet1").Cells(i, 9)
y = Worksheets("Sheet1").Cells(i, 10)
Z = Worksheets("Sheet1").Cells(i, 11)
Cells(j, 1) = p
Cells(j, 2) = q
Cells(j, 3) = r
Cells(j, 4) = s
Cells(j, 5) = t
Cells(j, 6) = u
Cells(j, 7) = v
Cells(j, 8) = w
Cells(j, 9) = x
Cells(j, 10) = y
Cells(j, 11) = Z
j = j + 1
Else
End If
i = i + 1
Wend
End Sub
Source Sheet
Target Sheet - pictures are not copied
Why the images in cell "q" Cells (i,2) are not copied to cells (j,2) in the other sheet?
Edit - I just looked at your code and you're not actually copy/pasting anything, which explains why images aren't carried over.
If you also need images the maybe switch to copy/paste instead of setting values.
Sub Worksheet_Activate()
Dim i As Long, j As Long, wsData As Worksheet, shp As Shape
Me.Range("A4:K2000").ClearContents
'remove any previous shapes
For Each shp In Me.Shapes
shp.Delete
Next shp
Me.Range("D1").Select
Application.ScreenUpdating = False
Set wsData = ThisWorkbook.Worksheets("Sheet1")
j = 4
For i = 4 To wsData.Cells(Rows.Count, 7).End(xlUp).Row
If wsData.Cells(i, 7) = "Waterjet" Then
'adjust the destination row height before pasting
Me.Cells(j, 1).RowHeight = wsData.Cells(i, 1).Height
wsData.Cells(i, 1).Resize(1, 11).Copy Me.Cells(j, 1)
j = j + 1
End If
Next i
End Sub
Shapes typically are copied along with their underlying ranges. If that's not happening there's a setting you can adjust before the copy/paste operation:
Application.CopyObjectsWithCells = True
There's a checkbox for this in the Excel Options dialog.
I'm trying to make a macro that increases the time between data points as part of automatic data processing, but it currently takes way too long.
One of my sensors logs a data point every 10 seconds, I want to increase this dt to 1 hour. For this I wrote some very simple (inefficient) code (see below) that does work but takes 10-40 minutes to process 1 week of data which is far from ideal.
I've seen recommendations for semi-similar issues to use an array, however I have 0 experience with this and don't know if it's applicable to this goal.
Do While Cells(row + 1, 2).Value <> ""
If Cells(row + 1, 2).Value - Cells(row, 2).Value < 1 / 24.05 Then
Rows(row + 1).Select
Selection.Delete Shift:=xlUp
Else
row = row + 1
End If
Loop
EDIT:
I solved my issue with a slightly edited version of #Damian's code as shown below.
Sub Change_dt()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long, Z As Long
x = 1
Z = 1
For i = 1 To UBound(arrSource)
On Error Resume Next
If arrSource(i + Z, 1) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than target both will be copied to the final array
If arrSource(i + Z, 1) - arrSource(i, 1) > target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + Z, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
i = i + Z
Z = 1
Else
Z = Z + 1
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
This should help a lot in your executing time:
Sub Change_dt()
Dim target As Single
target = Sheets("Controller").Cells(16, 9).Value
Dim arrSource As Variant
With ThisWorkbook.Sheets("Raw data")
arrSource = .UsedRange.Value 'this will input the whole used sheet inside the array
Dim finalArr As Variant
ReDim finalArr(1 To UBound(arrSource), 1 To UBound(arrSource, 2))
.Cells.Delete 'will clean the worksheet
Dim i As Long, x As Long, j As Long
x = 1
For i = 5 To UBound(arrSource)
On Error Resume Next
If arrSource(i + 1, 2) = vbNullString Or i = UBound(arrSource) Then Exit For 'will end the loop once the next row is empty
On Error GoTo 0
'If the next row substracted the first is greater than 1/24.05 both will be copied to the final array
If Not arrSource(i + 1, 2) - arrSource(i, 2) < target Then
For j = 1 To UBound(arrSource, 2)
finalArr(x, j) = arrSource(i, j)
finalArr(x + 1, j) = arrSource(i + 1, j)
Next j
x = x + 2 'increment 2 on x because you wrote 2 lines
End If
Next i
'paste the resulting array back to the sheet
.Range("A1", .Cells(UBound(finalArr), UBound(finalArr, 2))).Value = finalArr
'eliminate the extra unused rows
i = .Cells(.Rows.Count, 1).End(xlUp).row + 1
.Rows(i & ":" & .Rows.Count).Delete
End With
End Sub
The end goal for my project is that the user will be able to select a value from a ComboBox to fill out a report on a Summary Tab. The report will consist of 3, 3 cell ranges (divided into 3 1x3 ranges on 3 separate worksheets).
I want to find the row with the value the user selected in the ComboBox and then set the 9 cells to the right of that value equal to the values in the range mentioned previously.
I've tried a couple of different ways of doing this, but I'll include the code I most recently worked on below:
Private Sub OKButton1_Click()
Dim userValue, rangeOne, rangeTwo, rangeThree
Dim i As Long
i = 4
userValue = ComboBox1.Value
Set rangeOne = Sheets("Sheet2").Range(Range("F23:H23")
Set rangeTwo = Sheets("Sheet3").Range("F90:H90")
Set rangeThree = Sheets("Sheet4").Range("F17:H17")
While Sheets("Reports").Range(cells(i,1)).Value <> ""
If Sheets("Reports").Range(cells(i, "A")).Value = "userValue" Then
Set Sheets("Reports").Range(Cells(i, "B:E")) = rangeOne
Set Sheets("Reports").Range(Cells(i, "F:I")) = rangeOne
Set Sheets("Reports").Range(Cells(i, "J:M")) = rangeOne
End If
i = i + 1
Wend
Unload UserForm2
End Sub
Any Ideas on how I can improve this or get it working? Currently getting 1004 errors.
Two words of advice when working with excel:
always make variables for each sheet/book you need to work with
Avoid using ranges and objects if you can. It is much easier to iterate over individual cells using an array and a for loop like I did below.
I was a bit confused on exactly what you needed done, so you will need to modify this slightly to fit your ranges/where you want the data to go. If you are confused or need further assistance let me know and I'll update this.
Dim userValue
Dim xrow As Long, ws1 As Worksheet, ws2 As Worksheet, ws3 as Worksheet, ws4 as Worksheet
Dim arrData() as variant
set ws1 = Worksheets("Report")
set ws2 = Worksheets("Sheet2")
set ws3 = Worksheets("Sheet3")
set ws4 = Worksheets("Sheet4")
userValue = ComboBox1.Value
xrow = 1
ws2.activate
'the InStr function checks if the first condition contains the second, and when it does, it returns 1, which in turn triggers the if statement
for x = 1 To ws2.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(0) = ws2.Cells(x, 2).value
arrData(1) = ws2.Cells(x, 3).value
arrData(2) = ws2.Cells(x, 4).value
else:
end if
next x
ws3.activate
for x = 1 To ws3.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(3) = ws3.Cells(x, 2).value
arrData(4) = ws3.Cells(x, 3).value
arrData(5) = ws3.Cells(x, 4).value
else:
end if
next x
ws4.activate
for x = 1 To ws4.Cells(rows.count, 1).end(xlup).row
if InStr(1, Cells(x, 1), userValue) > 0 Then
arrData(6) = ws4.Cells(x, 2).value
arrData(7) = ws4.Cells(x, 3).value
arrData(8) = ws4.Cells(x, 4).value
else:
end if
next x
ws1.activate
ws1.Cells(xrow, 1) = userValue
for y = 0 To 8
ws1.Cells(xrow, y+1).value = arrData(y)
next y
xrow = xrow + 1
For x = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(1, Cells(x, 1), UserValue) > 0 Then
ws1.Cells(x, 2) = ws2.Cells(23, 6).Value
ws1.Cells(x, 3) = ws2.Cells(23, 7).Value
ws1.Cells(x, 4) = ws2.Cells(23, 8).Value
ws1.Cells(x, 6) = ws3.Cells(90, 6).Value
ws1.Cells(x, 7) = ws3.Cells(90, 7).Value
ws1.Cells(x, 8) = ws3.Cells(90, 8).Value
ws1.Cells(x, 10) = ws4.Cells(18, 6).Value
ws1.Cells(x, 11) = ws4.Cells(18, 7).Value
ws1.Cells(x, 12) = ws4.Cells(18, 8).Value
Else:
End If
Next x
The above is what I'm working with now in place of the while loop.
I search any text within Worksheet2 and display the results in ListBox1.
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
'Populating listbox from search
Dim i As Long
For i = 2 To Sheet2.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(Sheet2.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
Sheet2.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
I want to search multiple worksheets instead but don't know how to achieve this without changing the code completely.
You're going to have to change the reference to Sheet2 if you want to look at multiple sheets. There's no way around that. But, it will make your code more flexible. Start by doing this:
Private Sub SearchButton_Click()
'ListBox1.Clear
ListBox1.RowSource = ""
ListBox1.ColumnHeads = False
'listbox column headers
Me.ListBox1.AddItem
For A = 1 To 8
Me.ListBox1.List(0, A - 1) = Sheet2.Cells(1, A)
Next A
Me.ListBox1.Selected(0) = True
Dim ws As Worksheet 'This is the new line of code where you define your worksheet
Set ws = ActiveWorkbook.Sheet2 'Replace all references below to Sheet2 with this
'Populating listbox from search
Dim i As Long
For i = 2 To ws.Range("A100000").End(xlUp).Offset(1, 0).Row
For j = 1 To 8
H = Application.WorksheetFunction.CountIf(ws.Range("A" & i, "H" & i), Sheet2.Cells(i, j))
If H = 1 And LCase(Sheet2.Cells(i, j)) = LCase(Me.TextBox2) Or H = 1 And _
ws.Cells(i, j) = Val(Me.TextBox2) Then
Me.ListBox1.AddItem
For X = 1 To 8
Me.ListBox1.List(ListBox1.ListCount - 1, X - 1) = Sheet2.Cells(i, X)
Next X
End If
Next j
Next i
End Sub
Now that you're generalized your Sub, you can modify the value of ws to repeat the code as much as you need to. If it is every sheet in your workbook, you can use a For Each loop, like
For Each ws In ActiveWorkbook
'All your code for the ws here
Next ws
Or, you can define the worksheets in an array beforehand.
Dim SheetList(0 to 2) As String
Dim k As Integer
SheetList(0) = "Sheet 2 Name"
SheetList(1) = "Sheet 4 Name"
SheetList(2) = "Sheet 3 Name"
SheetList(3) = "Sheet 6 Name"
For k = LBound(SheetList) To UBound(SheetList)
ws = ActiveWorkbook.Sheets(SheetList(k))
'The rest of your code from above
Next k
You didn't specify in your question what kind of sheets how many, or how they are organized. But, these options should be enough to get you where you are trying to go.
I need to loop over all rows (except my header rows) and merge all cells with the same value in the same column. Before I do this I already made sure, that the column is sorted.
So I have some setup like this.
a b c d e
1 x x x x
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x
And need this
a b c d e
1 x x x x
2 x x x x
x x x x
x x x x
3 x x x x
x x x x
With my code I achieved to merge two equal cells. Instead I need to merge all equal cells.
Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If Cells(i, 1) <> "" Then
If Cells(i, 1) = Cells(i - 1, 1) Then
Range(Cells(i, 1), Cells(i - 1, 1)).Merge
End If
End If
Next i
This method does not use merged cells, but achieves the same visual effect:
Say we start with:
Running this macro:
Sub HideDups()
Dim N As Long, i As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = N To 3 Step -1
With Cells(i, 1)
If .Value = Cells(i - 1, 1).Value Then
.Font.ColorIndex = 2
End If
End With
Next i
End Sub
will produce this result:
NOTE:
No cells are merged. This visual effect is the same because consecutive duplicates in the same column are "hidden" by having the colour of the font be the same as the colour of the cell background.
I know this is an old thread, but I needed something similar. Here's what I came up with.
Sub MergeLikeCells()
Dim varTestVal As Variant
Dim intRowCount As Integer
Dim intAdjustment As Integer
ActiveSheet.Range("A1").Select
'Find like values in column A - Merge and Center Cells
While Selection.Offset(1, 0).Value <> ""
'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
intRowCount = 1
varTestVal = Selection.Value
While Selection.Offset(1, 0).Value = varTestVal
intRowCount = intRowCount + 1
Selection.Offset(1, 0).Select
Selection.ClearContents
Wend
intAdjustment = (intRowCount * -1) + 1
Selection.Offset(intAdjustment, 0).Select
Selection.Resize(intRowCount, 1).Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Offset(1, 0).Resize(1, 1).Select
Wend
End Sub
My solution as below, have a good day!
Sub MergeSameValue()
Application.DisplayAlerts = False
Dim LastRow As Integer
Dim StartRow As Integer
StartRow = 2
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim StartMerge As Integer
StartMerge = StartRow
For i = StartRow + 1 To LastRow
If Cells(i, 1) <> "" Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
StartMerge = i
End If
End If
Next i
End Sub