My code does what I want, but it copies it to column A in sheet 2. I would like it to put the data in starting at Column B if possible.
Sub EFP()
Dim keyword As String: keyword = Sheets("Results").Range("B3").Value
Dim countRows1 As Long, countRows2 As Long
countRows1 = 3 'the first row of my dataset in the Data tab
endRows1 = 500 'the last row of my dataset in the Data tab
countRows2 = 6 'the first row where I want to start writing the found rows
For j = countRows1 To endRows1
If Sheets("Data").Range("B" & j).Value = keyword Then
Sheets("Results").Rows(countRows2).Value = Sheets("Data").Rows(j).Value
countRows2 = countRows2 + 1
End If
Next j
End Sub
If you copy and paste whole rows, they will always start in column A. If you want the result to start in column B, you need a different approach, for example
Sheets("Results").Range("B" & countRows2 & ":Z" & countRows2).Value = Sheets("Data").Range("A" & j & ":Y" & j).Value
I have the following formula:
=IF(IFERROR(MATCH($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$A$49,0),0),VLOOKUP($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$B$49,2,FALSE),0)
In A1 I have another date: 10.10.2016
How can I replace only the date that is in the file name from the formula?
Until now, I've been using this:
Sub modify()
Dim a As Range
Set a = Range("a1")
[e3:e4].Replace "dones 05.10.2016.xls", ("dones " & a & ".xls"), xlPart
End Sub
The problem that in A2 I have another date and F3:F4 must have the date from A2, and so on until A300. How can I replace only the date of the file name in the formula?
The names of the files are standard: dones dd.mm.yyyy.xls
Sub modify()
Dim c As Range, r As Range
Set c = [a1]
Set r = [e3:e4]
Application.DisplayAlerts = False ' optional to hide dialogs
While c > ""
Debug.Print c.Address(0, 0), r.Address(0, 0) ' optional to check the address
r.Replace "[dones ??.??.????.xls]", "[dones " & c & ".xls]", xlPart
Set c = c.Offset(1, 0) ' A1 to A2
Set r = r.Offset(0, 1) ' E3:E4 to F3:F4
Wend
Application.DisplayAlerts = True
End Sub
Replace with wildcards:
[e3:e4].Replace "[dones ??.??.????.xls]", "[dones " & [a1] & ".xls]", xlPart
? matches any single character and * can be used to match 0 or more characters:
[e3:e4].Replace "[*.xls*]", "[dones " & [a1] & ".xls]", xlPart
https://www.ablebits.com/office-addins-blog/2015/09/29/using-excel-find-replace/#find-replace-wildcards
Instead of hard-coding "dones 05.10.2016.xls", you'll have to build that string from the cell values. Also, you'll need some looping logic to track which row you're reading from and which column you're writing to.
Assuming a date read in row 1 goes in column 5, a date read in row 2 goes in column 6, and so on, something like this should be good enough:
Dim targetColumn As Long
Dim sourceRow As Long
With ActiveSheet
For sourceRow = 1 To WhateverTheLastRowIs
targetColumn = 4 + sourceRow 'column 5 / "E" for sourceRow 1
Dim sourceDateValue As Variant
sourceDateValue = .Cells(sourceRow, 1).Value
Debug.Assert VarType(sourceDateValue) = vbDate
Dim formattedSourceDate As String
formattedSourceDate = Format(sourceDateValue.Value, "MM.DD.YYYY")
'replace string in rows 3 & 4 of targetColumn:
.Range(.Cells(3, targetColumn), .Cells(4, targetColumn) _
.Replace "[*.xls]", "[dones " & formattedSourceDate & ".xls]", xlPart
Next
End With
My understanding of the requirements is this:
There is a List of Dates in Column A starting at Row 1
A formula needs to be entered in rows 3:4 starting in Column E and moving one column to the right for each value in the List of Dates, i.e. Formula in column E has date from row 1, column F has date from row 2, …
This is the formula, in which the date 05.10.2016 in the filename '\\share\done\[dones 05.10.2016.xls]done should be update with corresponding value from the List of Dates as per point 2.
=IF(
IFERROR(MATCH($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$A$49,0),0),
VLOOKUP($C3,'\\share\done\[dones 05.10.2016.xls]done'!$A$2:$B$49,2,FALSE),0)
This solution assumes the dates in column A are already formated as required by the filename link.
This solution uses a variable to hold the Link Formula and another variable to update the Link Formula with each Value in the List of Dates.
Also to simplify the update\replacement of the date let’s change the original date in the formula for 05.10.2016 for an unique key such as #DATE
Dim sFmlLink As String, sFml As String
sFmlLink = "=IF(" & Chr(10) & _
"IFERROR(MATCH($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,0),0)," & Chr(10) & _
"VLOOKUP($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,2,FALSE),0)"
Then we set a Range with the List of Dates and loop trough it to update and enter the formula as per point 2.
Sub FormulaLink()
Dim sFmlLink As String, sFml As String
sFmlLink = "=IF(" & Chr(10) & _
"IFERROR(MATCH($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,0),0)," & Chr(10) & _
"VLOOKUP($C3,'\\share\done\[dones #DATE.xls]done'!$A$2:$A$49,2,FALSE),0)"
Dim rDates As Range, lRow As Long, iCol As Integer
Rem Set Start Column
iCol = 5
With ThisWorkbook.Sheets("DATA")
Rem Set Dates List Range
Set rDates = Range(.Cells(1), .Cells(Rows.Count, 1).End(xlUp))
Rem Enter Link Formula in Rows 3:4, starting at Column 5
Rem and moving one column to the right for each Date in Column A
For lRow = 1 To rDates.Rows.Count
Rem Refresh Link Formula with Date from Column A
sFml = Replace(sFmlLink, "#DATE", rDates.Cells(lRow).Value)
Rem Enter Formula in Column iCol Rows 3:4
.Cells(3, iCol).Resize(2).Formula = sFml
Rem Move One Column to the right
iCol = 1 + iCol
Next: End With
End Sub
You will need to work with the string functions InStr and Mid here. Maybe this can help you:
Dim str As String
Dim intPos1 As Integer
Dim intPos2 As Integer
Dim intLastPos As Integer
'Formula as string
str = "\\share\done\[dones 05-10-2016.xls]done'!$A$2:$A$49,0),0),VLOOKUP($C3,'\\share\done\[dones 05-10-2016.xls]done"
'Get the start and the End Position of the First Excel File
intPos1 = InStr(1, str, "[dones") - 1
intPos2 = InStr(1, str, ".xls") + 5
'Save the Last Postion for the second Replacement
intLastPos = intPos2
'Replace old File with [dones 01-10-1911.xls]
str = Mid(str, 1, intPos1) & "[dones 01-10-1911.xls]" & Mid(str, intPos2, Len(str))
'Get the start and the End Position of the second Excel File
intPos1 = InStr(intLastPos, str, "[dones")
intPos2 = InStr(intLastPos, str, ".xls")
'Replace the second File with [dones 01-10-1911.xls]
str = Mid(str, 1, intPos1) & "[dones 01-10-1911.xls]" & Mid(str, intPos2, Len(str))
After that you can read back the formula.
So I'm hoping for some help to automate a process that will otherwise involve copying and editing some 10,000 rows.
This is stuff relating to location data. Essentially, there are tons of these Master Rows but they do not have individual rows for Unit Numbers. I am hoping to get something to expand these into individual Unit Number rows based on what is in Column N. Column N is intended to follow a strict format of being a comma-seperated single cell list for each row.
Below is an example from Sheet 1 of what each row will have and needs to be expanded upon. Note that Column N is green and follows a consistent formatting and this will be the determinant for how many times these rows will each be expanded upon.
Below is Sheet 2 and what I want the VBA to create from Sheet 1. You can see that each row has been expanded based on the contents of Column N from Sheet 1.
Like I said, it is expected that this will involve some several thousand rows to create.
Option Explicit
Sub Tester()
Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value
Set rwDest = sht2.Range("A2:M2") 'destination start row
Set rwSrc = sht1.Range("A2:M2") 'source row
Do While Application.CountA(rwSrc) > 0
v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values
If InStr(v, ",") > 0 Then
'list of values: split and count
arr = Split(v, ",")
n = UBound(arr) + 1
Else
'one or no value
arr = Array(v)
n = 1
End If
'duplicate source row as required
rwDest.Resize(n, 13).Value = rwSrc.Value
'copy over the unit values
rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr)
'offset to next destination row
Set rwDest = rwDest.Offset(n, 0)
'next source row
Set rwSrc = rwSrc.Offset(1, 0)
Loop
End Sub
This does the work in same sheet... Pls copy the value to "Sheet2" before executing this. Not sure about efficiency though.
Public Sub Test()
Dim lr As Long ' To store the last row of the data range
Dim counter As Long
Dim Str As String ' To store the string in column N
lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data
For i = lr To 2 Step -1
Str = Range("N" & i).Value ' Getting the value from Column N
counter = 1
For Each s In Split(Str, ",")
If counter > 1 Then
Range("A" & (i + counter - 1)).EntireRow.Insert ' Inserting rows for each value in column N
Range("G" & (i + counter - 1)).Formula = s ' Updating the value in Column G
Else
Range("G" & i).Formula = s ' No need to insert a new row for first value
End If
counter = counter + 1
Next s
Next i
lr = Range("G65536").End(xlUp).Row
' Pulling down other values from the first value row other rows
Range("A1:N" & lr).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Pasting the data as Values to avoid future formula issues.
Range("A1:N" & lr).Copy
Range("A1:N" & lr).PasteSpecial xlPasteValues
MsgBox "Done"
End Sub
I apologize for all the text, but this is a little complex and I wish to avoid confusion:
I need code that will insert one empty row when two consecutive cells in a column are the not the same (e.g., If H2 <> H3, then insert an empty row beneath row 2). However, it must also be able to insert two empty rows when any two or more consecutive cells in a column are the same (e.g., If H4 = H5, then insert two empty rows beneath H5, or if H4 = H5 = H6, then insert two empty rows beneath H6.)
The point is to have one empty row separating all data-containing rows in which the value in column H is not the same, and to have two rows beneath groups of rows in which the value in column H is the same. That leaves an extra empty row beneath the group so the extra empty row can contain a sum of the group's values in column P.
I have figured out how to do the first task with this code:
Sub SepFcpDs()
Application.ScreenUpdating = False
Dim LastRow As Integer
'Search code
LastRow = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim i As Long
'Begin loop code
For i = 2 To LastRow
'Insert an empty row if FcpDs do not match
If (Range("H" & i) <> Range("H" & i).Offset(1)) And Not IsEmpty(Range("H" & i)) Then
Range("H" & i).Offset(1).EntireRow.Insert
End If
Next i
Application.ScreenUpdating = True
'End loop code
End Sub
I cannot figure out how to make it find groups of rows, which may be of any size, in which groups of rows in column H are the same, and then to insert an extra row beneath these groups. I have tried modifying the code above as such:
If (Range("I" & i) = Range("I" & i).Offset(-1)) _
And (Range("I" & i) = Range("I" & i).Offset(-2)) And Not IsEmpty(Range("I" & i)) Then
Range("I" & i).EntireRow.Insert
End If
This code does not work (returns Run-time error '1004': Application-defined or object-defined error). How do I fix this?
This will do the trick.
Sub SepFcpDs()
Application.ScreenUpdating = False
Dim LastRow As Integer
Dim LastRowWithValue As Integer
Dim Column As String
ColToSearch = "H"
'Search code
LastRow = ActiveSheet.Cells(Rows.Count, ColToSearch).End(xlUp).Row
Dim i As Long
'Begin loop code
LastRowWithValue = LastRow
For i = LastRow To 3 Step -1
'Insert an empty row if FcpDs do not match
If (Range(ColToSearch & i) <> Range(ColToSearch & i).Offset(-1)) Then
If i <> LastRowWithValue Then
Range(ColToSearch & (LastRowWithValue + 1)).EntireRow.Insert
End If
Range(ColToSearch & i).EntireRow.Insert
LastRowWithValue = i - 1
End If
Next i
Application.ScreenUpdating = True
'End loop code
EDIT: Updated to work even if there are multiple groupings of the same value in the column. This won't deal with the next column if you have different requirements, but should at least be a start.
I have this code:
Dim first As Integer
Dim Last As Integer
Dim i As Integer
For i = 1 To 17
first = (ActiveCell.Row + 1)
Selection.End(xlDown).Select
Last = (ActiveCell.Row - 1)
Range("J" & first & ":J" & Last).Select
Selection.Value = "=J$" & (first - 1)
Range("A" & Last + 1).Select
Next i
and would like to be able to replace the 17 with a variable because some of the workbooks have an extra group. I can't just count the number of rows as there is information between first and last but in different columns.
Is there a way to count the number of cells that have data in a set column where the data may not be contiguous (then I can replace the 17 with a variable that is equal to variable -1)?
Found it online: Thanks.
n = Worksheets("Sheet1").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count