VBA - looping through cells using "i" - arrays

I am trying to loop through a range on cells in a column and then check if the cell is empty, if it is, I want to copy the corresponding row into a new sheet. This is what I have so far:
If Len(Cells(i, 17)) = 0 Then
Sheets("GES1").Activate
ActiveSheet.Range(Cells(i, 1), Cells(i, 17)).Select
Selection.Copy
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Paste
End If
Next i
The problem with this code is that as soon as there is an empty cell the corresponding row gets copied and pasted into a new sheet and the following rows also get copied and pasted into new sheets even if their corresponding cells are not blank. I want the code to copy and paste any row corresponding to an empty cell value in column Q i.e 17 to a single new sheet

Problem is with this line. Try correcting it.
Worksheets.Add after:=Sheets(Sheets.Count)

I believe that you want all of the rows with a blank column Q cell to be copied to a single new worksheet.
Sub copy_blank_to_new()
Dim i As Long, ws As Worksheet
Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
With Sheets("GES1")
.Cells(1, 1).Resize(1, 17).Copy Destination:=ws.Cells(1, 1)
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If Not CBool(Len(Cells(i, 17).Value)) Then _
.Cells(i, 1).Resize(1, 17).Copy _
Destination:=ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next i
End With
Set ws = Nothing
End Sub
That starts by copying the first row across. I've guessed that is column header label information. It then copies each row with a blank (actually zero-length value) into subsequent rows in the same new worksheet.
If column Q could be blank then there is the distinct possibility that other columns could contain blanks. I've used column A to determine the extents of the data to be examined. If this is insufficient, there are other methods but having some idea of what your data actually looks like would help.

Related

VBA to look for value in multiple sheets then copy adjacent row all what's in the left

i have column "A" each cell in it contains value, i want to look for each value in all sheets in the workbook, when find the matching value, then copy all what's in the left of that cell from the found sheet to the master sheet taking in consideration the bellow points :
Found sheet the range order i want to copy is : E-D-C-B-A (From found cell going left until the beginning of row)
Master Sheet the copied range i want past in this order : A-B-C-D-E (A will be in column "A" the rest will be pasted to the right and go on
i tried with this peace of code but i keep getting errors .
this code does have loop command yet and still struggling with copy all to the left .
enter image description here
Sub Plan_Rout()
Dim Fnd As Range, A1 As Range
Dim Lr As Long
With Sheets("sheet1")
For Each A1 In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
Set Fnd = Sheets("Sheet2").Range("A1:Z50").Find(A1.Value, , xlFormulas, xlWhole,
xlByRows, xlPrevious, False, , False)
If Not Fnd Is Nothing Then A1.Offset(, 1).Value = Fnd.Offset(, -1).Value
If Not Fnd Is Nothing Then A1.Offset(, 2).Value = Fnd.Offset(, -2).Value
'if i add another with offset 3 i get error'
Next A1
End With
End Sub

Insert array of text into last row

For the life of me I cannot figure this out. I have a summary spreadsheet that is compiled based on multiple other sheets within the same workbook. On the main sheet I find the last row and need to insert row with text but cannot. Getting stuck. I'm using an array as these fields will never change. But only the first value of the array is displaying and not the rest.
Here's my code:
sub Headers()
Dim last_row As Long
Dim Header() As Variant
Header = VBA.Array("koko", "momo", "dodo", "gogo")
last_row = Cells(Rows.Count, "B").End(xlUp).Row + 1
ActiveSheet.Cells(last_row, "A").Value = Header
End Sub
enter image description here
You have to resize the target range to get the full array contents
ActiveSheet.Cells(last_row, "A").Resize(1, UBound(Header) + 1).Value = Header
:-)
To put the array in several columns within one row simply resize the target. Remember that arrays are zero-based by default.
ActiveSheet.Cells(last_row, "A").Resize(1, Ubound(header)+1).Value = Header
To put the array in several rows within one column resize the target and transpose the array.
ActiveSheet.Cells(last_row, "A").Resize(Ubound(header)+1, 1).Value = application.transpose(Header)
To put the array into a single cell, Join the array.
ActiveSheet.Cells(last_row, "A").Value = Join(Header, ", ")

Looping through rows, copy cell and then move back to the original sheet in a new loop

I have been trying to put together the code for the following request, I am not an expert and I really need help on this, thanks in advance:
There are 2 sheets 1 "Database", 2 "Scorecard".
Loop through the rows in column C Database Sheet, each single value
will be copied into the Scorecard sheet Cell B3, this will change the
value of the cell C30.
The new value for cell C30 will then need to be copied back to the Database Sheet in new column "F", and this will be looped till the
last cell. Filling the list.
It requires to be correspondent to the the cell, thus the first value in C2 will need the matching value in F2 and so on.
The database will change in time so it requires a code that allows to consider new entrances.
I have tried to modify this code I've seen in a different question: Loops in VBA? I want to use a loop to select and copy till last cell but can't make it work...
Thanks so so much!
Sub LoopThroughColumnC()
Dim LastRowInColC As Long, Counter As Long
Dim SourceCell As Range, DestCell As Range
Dim MySheet As Worksheet
'set references up-front
Set MySheet = ThisWorkbook.Worksheets("Dati per calcolo")
Set CopySheet = ThisWorkbook.Worksheets("Scheda costo tessuto e capo")
With MySheet
LastRowInColC = .Range("C" & .Rows.Count).End(xlUp).Row
Set DestCell = ThisWorkbook.Worksheets("Scheda costo tessuto e capo").Range("B3")
End With
'loop through column C, copying from cells(counter, 11) to B3
With MySheet
For Counter = 1 To LastRowInColC
Set SourceCell = .Range("C" & Counter)
SourceCell.Copy Destination:=DestCell
If Target.Address = Range("A1").Address Then
' Get the last row on our destination sheet (using Sheet2, col A here)...
Dim intLastRow As Long
intLastRow = Sheet2.Cells(Sheet2.Rows.Count, "B").End(xlUp).Row
' Add our value to the next row...
Sheet2.Cells(intLastRow + 1, "A") = Target.Value
End If
Next Counter
End With
End Sub

Filter column based on array from another sheet

I have three sheets called: "Dane magazyn", "Sheet3" and "Dostawcy".
What I want my Excel to do is:
1) filter out #N/A values in col. J on sheet "Dane magazyn". All values that should stay after filtering are stored in Col. E on sheet "Dostawcy" - 21 entries, but it will be more in the future.
2) select data that remained after filtering and copy to "Sheet3"
Here's my code so far:
Sub filtruj()
Dim i As Long, arr As Variant, LastRow As Long
Sheets("Dostawcy").Select
With ActiveSheet
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
arr = Sheets("Dostawcy").Range("E2:E" & LastRow).Value
Sheets("Dane magazyn").Select
With ActiveSheet
**.Columns("J").AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues** <---- here I get error
End With
Rest of code...
Error message I get is:
"Run-time error '1004':
AutoFilter method of Range class failed"
websites I've checked (not all listed)
Using string array as criteria in VBA autofilter
VBA assign a range to an Array from different sheet
Fastest way to read a column of numbers into an array
Thanks in advance
Here is working code:
Dim rng, rngToFilter As Range
Dim i As Integer: i = 1
'set you range to area with values to compare against
'if you can, specify here exact range instead of whole column, it can increase efficiency
Set rng = Sheets("Dostawcy").Range("E:E")
'set range to be filtered out, don't specify here whole column,
'in following loop it can result in overflow error
Set rngToFilter = Sheets("Dane magazyn").Range("J1:J100")
'here we will iterate through all cells within the searched range,
'for every cell we will try to find it's value within the other range,
'if it succeeds, so it's not Nothing, then we copy it to Sheet3
For Each cell In rngToFilter
'if any cell causes the error, we will skip one iteration
On Error GoTo ErrorHandler:
If Not rng.Find(cell.Value) Is Nothing Then
Sheets("Sheet3").Cells(i, 1).Value = cell.Value
i = i + 1
End If
ErrorHandler:
Next cell
Don't use Select unless you must, it reduces efficiency of a program.

Excel VBA find/replace loop - really new at VBA

I need to add a section within an existing macro that takes a cell's address and looks for that address (as a string?) from the values within a range of cells elsewhere on the sheet - then offsets one column over to use that cell's value to replace the original value of the cell who's address was searched.
My code is looking for unmerged cells, and when it finds an unmerged cell, it needs to grab the correct value to put in there. Not all cells in my range mCell are unmerged, so this is a find/replace within a loop.
I cannot hard code the cells, and also cannot figure out a functional loop that successfully moves through my range and finds/replaces using values from another part of the worksheet. I'm new at VBA and keep getting errors and wind up defining a dozen ranges and strings trying to carry over the data. Any help would be greatly appreciated!
For example:
if unmerged mCell.address = "B20", then the macro finds the value "B20" in a designated range (in example below, was found in cell Q20), then offset one column over (to cell R20), then uses value of that cell (which is 6) to replace the value of mcell, such that the new cell value of B20 (i.e., the active mCell) = 6. Then on to the next unmerged mCell...
row Column Q Col. R '(not code, but can't get formatting any other way)
18 B18(text) 5
19 B19 4
20 B20 6
21 B21 3
Thank you for any suggestions, My existing code works great until "Part II", but then I'm failing miserably and am requesting specific help on how to correct/improve the code. Existing code is:
' This sub looks for the word "Table" in column A. If the word appears, it unmerges the cells in columns B - E
' and the rows following to allow for the insert of a table, then merges all other rows for sake of format.
Option Explicit
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Range("B14:E64").SpecialCells(xlCellTypeVisible).Select
With Selection
.RowHeight = 17
.VerticalAlignment = xlTop
.HorizontalAlignment = xlLeft
.WrapText = True
End With
'*******Merge or unmerge rows according to whether or not they contain Table data -
' this only acts on visible cells, so rows of data table can be hidden as needed
Dim TA As Integer
Dim ColValues As Variant
Dim rng As Range
Dim tabNo As Range 'uses value on worksheet to know how many rows to unmerge
'*******Dims in finding and replacing unmerged cell values
Dim mergeRange As Range 'Range B16:E64 - where my mCells are being pulled from
Dim mCell As Range 'Cell that is unmerged, looking for its address
Dim ws As Worksheet
Dim tabledata As Range 'Range Q11:Q38 - this is the column I'm searching in and offsetting from
Dim aCell As String 'picks up cell address, to use in .find
Dim myCell As Range 'cell address in Q
Dim ReplaceString As String
Dim foundCell As Range
Dim bCell As Range
Dim i As Long
Application.DisplayAlerts = False
'Make column B = Column A values, cannot make this happen on sheet, because data is too variable
ColValues = ActiveSheet.Range("A16:A64").Value
ActiveSheet.Range("B16:B64").Value = ColValues
'Look for data table, if not present, merge cells
Set rng = ActiveSheet.Range("B14:B100")
Set tabNo = ActiveSheet.Range("K6")
For TA = 15 To 64 'defines TA variable to loop from row 14 to row 64
If Cells(TA, "A") = "Table" Then '
Range("B" & TA & ":E" & TA + tabNo).UnMerge 'unmerges the row with "Table" listed and the next 7 rows (to make a 8-row x 4 column unmerged area for table
TA = TA + tabNo ' moves active cell "TA" down 7 spaces
Else
Range("B" & TA & ":E" & TA).Merge 'If "Table" not found, then merge the cells for the row TA is in across columns B:E
End If
Next TA
'*** Part II: Need some calculation to loop or offset or find through data and fill
'unmerged cells from a data table on the worksheet.
'the placement of the data table varies depending on the layout of the report,
'which changes day to day, so can not be hard coded into the cells - needs to look up
'position of the word "Table" and dump data after that.
'offset? .find? loop?
'***want to take the cell address of each unmerged cell within the range of the report
'and look for that cell in an array, then replace the cell contents with the correct value
Set mergeRange = ActiveSheet.Range("B16:E64")
For Each mCell In mergeRange
' If mergeRange.MergeCells = True Then
' MsgBox "all cells are merged, exiting sub"
' Exit Sub
'Else
If mCell.MergeCells = False Then
aCell = mCell.Address '??? Need to set the cell address as
'a text string or something in order to look for that address in the values
'of cells in range "tabledata"
'MsgBox "aCell " & Range(aCell).Address
Set tabledata = ActiveSheet.Range("Q11:Q38")
Set bCell = tabledata.Find(aCell, After:=Range("Q1"), LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'this gives me a "type mismatch" error that I cannot clear
'- then wanting the value of the cell offset one column over
'need to take the value of that offset cell and use it
'to replace the value of the original unmerged cell (mCell)
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(0, 1).Value = ActiveCell.Value
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Next mCell
End Sub
There were a few problems in there but I think it's working now. You'll have to verify as I'm still not 100% sure what it is supposed to do.
Problem 1: You don't need tabledata. You specify in the search parameters After:=Range("Q1") so it's looking in the right place. Find works on a Cells so your line should be:
Set bCell = Cells.Find(aCell, After:=Range("Q1"), LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Problem 2: Your line aCell = mCell.Address needs to be aCell = Replace(mCell.Address, "$", "") as it comes in as an absolute cell reference and the cell address on your sheet are not (probably a more elegant way of doing this).
There were a couple of other problems in your Dropbox file but those should be sorted too now. There was an extra Next and the line aCell.Offset(, 1) = bCell.Offset(, 1) seems like it should be mCell.Offset(, 1) = bCell.Offset(, 1).
https://www.dropbox.com/s/jqdg3v0gd59mxjn/Test%20Workbook%201016jb.xlsm

Resources