I want to import values from a dynamic worksheet to our "Database" sorted by the title of the column. As you can see I have scraped together something that works, but it is very slow and doesn't copy just the values.
The first row of the sheet is the titles, the second and further down rows are the values I want to copy.
Sub Copypasta()
Sheets("copypasta").Select
Sheets("copypasta").Range("A2").Activate
While Not ActiveSheet.Cells(1, ActiveCell.Column) = ""
t1 = ActiveSheet.Cells(1, ActiveCell.Column)
Selection.Copy
Set MyActiveCell = ActiveCell
Sheets("Database").Activate
lnCol = Sheets("Database").Cells(1, 1).EntireRow.Find(What:=t1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
lnRow = Sheets("Database").Range("a65536").End(xlUp).Row
If lnCol > 1 Then Sheets("Database").Cells(lnRow, lnCol).Activate Else Sheets("Database").Cells(lnRow, lnCol).Offset(1, 0).Activate
ActiveSheet.Paste 'xlPasteValues
Sheets("copypasta").Activate
MyActiveCell.Offset(0, 1).Activate
Wend
End Sub
I tried to use PasteSpecial xlPasteValues or setting the value of the cell directly, but I can't get it to work. I am googling every error it throws and then search the code for where the error occurs.
Try the code below:
Option Explicit
Sub Copypasta()
Dim CopySht As Worksheet
Dim DBSht As Worksheet
Dim i As Long, lnCol As Long, lnRow As Long
Dim MyActiveCell As Range, FindRng As Range
Dim t1
' set the Worksheet objects
Set CopySht = ThisWorkbook.Sheets("copypasta")
Set DBSht = ThisWorkbook.Sheets("Database")
' set the anchor position on the loop
Set MyActiveCell = CopySht.Range("A2")
' loop through columns at the first row (until you reach a column that is empty)
While CopySht.Cells(1, MyActiveCell.Column) <> ""
t1 = CopySht.Cells(1, MyActiveCell.Column)
MyActiveCell.Copy
With DBSht
lnRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' find last row with data in Column "A"
Set FindRng = .Rows(1).Find(What:=t1, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not FindRng Is Nothing Then ' check if Find was successful
lnCol = FindRng.Column
Else
lnCol = 1
End If
' there's no need to use Select and Activate to Copy and/or Paste
.Cells(lnRow + 1, lnCol).PasteSpecial xlPasteValues
End With
Set MyActiveCell = MyActiveCell.Offset(0, 1) ' loop one column to the right
Wend
End Sub
Related
I'm trying to make a Macro to clean Dataset by deleting blank cells using an Autofilter method with a header instead of a column number. As you can see. There is no Cells number in this Macro and there will not. Everything has to be automatic. That is the idea.
I wrote 90% of the code. I arrived at the water source but I can not drink.
I got the error for the last line.
Error 1004: AutoFilter method of Range class failed.
Here is the code:
Sub DeleteBlank()
Dim WrkS As Worksheet, LsC As Range, FsC As Range, Tab As Range
Dim LsH As Range, RNbr As Long, CNbr As Long, HdrRow As Range, FltCol As Variant
Set WrkS = Worksheets("data")
' Last cells
Set LsC = Cells(Cells.Find(what:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).row, _
Cells.Find(what:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
' First cells
Set FsC = Cells(Cells.Find(what:="*", after:=LastCell, SearchOrder:=xlRows, _
SearchDirection:=xlNext, LookIn:=xlValues).row, _
Cells.Find(what:="*", after:=LastCell, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, LookIn:=xlValues).Column)
FsC.Activate
RNbr = ActiveCell.row
LsC.Activate
CNbr = ActiveCell.Column
'to set the last header
Set LsH = Cells(RNbr, CNbr)
' to set the header Row
Set HdrRow = Range(FsC, LsH)
Set Tab = WrkS.UsedRAnge
' to get the Column name in which I have to delete all blank
With HdrRow
FltCol = .Find(what:="name", LookAt:=xlWhole).Column
End With
' the problem is below
' Error 1004: AutoFilter method of Range class failed.
WrkS.Tab.AutoFilter Field:=FltCol, Criteria1:="="
End Sub
Can you try this? I couldn't declare a variable called "Tab". Since it was already defined as a range on WrKS you don't need the sheet reference on the AF line. Also, when using Find best to check the value is found to avoid errors. You should really use sheet references everywhere (or activate the sheet at the beginning).
Sub DeleteBlank()
Dim WrkS As Worksheet, LsC As Range, FsC As Range, Tab1 As Range
Dim LsH As Range, RNbr As Long, CNbr As Long, HdrRow As Range, FltCol As Variant
Set WrkS = Worksheets("data")
Set LsC = Cells.Find(what:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues)
Set FsC = Cells.Find(what:="*", after:=LastCell, SearchOrder:=xlRows, SearchDirection:=xlNext, LookIn:=xlValues)
If Not FsC Is Nothing Then
If Not LsC Is Nothing Then
RNbr = FsC.Row
CNbr = LsC.Column
Set LsH = Cells(RNbr, CNbr)
Set HdrRow = Range(FsC, LsH)
Set Tab1 = WrkS.UsedRange
FltCol = HdrRow.Find(what:="name", LookAt:=xlWhole).Column
Tab1.AutoFilter Field:=FltCol, Criteria1:="="
End If
End If
End Sub
maybe you can shorten it down to this
Option Explicit
Sub DeleteBlank()
With Worksheets("data").UsedRange ' reference relevant worksheet "usedrange"
With Intersect(.Rows(1).Find(what:="name", LookAt:=xlWhole).EntireColumn, .Cells) 'reference its column whose top cell content is "name"
.AutoFilter Field:=1, Criteria1:="=" 'filter referenced column blank cells
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete ' if any filtered cells other than first row (header) then delete their entire row
End With
.Parent.AutoFilterMode = False
End With
End Sub
I have 2 wb to_update_example_1 and purchasing_list
basically what I am trying to do is to a loop row by row on workbook to_update_example_1 if the same name is found to copy the a variable to the purchasing_list workbook.
However it keeps giving me error 91 at the searching portion and I would need an advice how do I write vVal2(which is the Qty) to Purchasing list workbook the column is just beside the found name so I tried to use active cell offset but didn't work too
any advice is appreciated thanks
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Integer
Dim vVal1, vVal2 As String
Numrows = Range("A1", Range("A1").End(xlDown)).Rows.Count ' Set numrows = number of rows of data.
Range("A1").Select ' Select cell a2.
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times.
vVal1 = Cells(x, 8)
vVal2 = Cells(x, 7)
Windows("Purchasing List.xls").Activate
ActiveSheet.Cells.Find(What:=vVal1, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
''write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
Windows("To_update_example_1.xlsm").Activate
''''''''ActiveCell.Offset(1, 0).Select
Next
Application.ScreenUpdating = True
End Sub
When using the Find function, it's recommended if you set a Range object to the Find result, and also prepare your code for a scenario that Find didn't find vVal1 in "Purchasing List.xls" workbook. You can achieve it by using the following line If Not FindRng Is Nothing Then.
Note: avoid using Select, Activate and ActiveSheet, instead fully qualify all your Objects - see in my code below (with comments).
Modified Code
Option Explicit
Sub Macro1()
Application.ScreenUpdating = False
Dim x As Long, Numrows As Long
Dim vVal1 As String, vVal2 As String
Dim PurchaseWb As Workbook
Dim ToUpdateWb As Workbook
Dim FindRng As Range
' set workbook object of "Purchasing List" excel workbook
Set PurchaseWb = Workbooks("Purchasing List.xls")
' set workbook object of "To_update_example_1" excel workbook
Set ToUpdateWb = Workbooks("To_update_example_1.xlsm")
With ToUpdateWb.Sheets("Sheet1") ' <-- I think you are trying to loop on "To_update_example_1.xlsm" file , '<-- change "Sheet1" to your sheet's name
' Set numrows = number of rows of data.
Numrows = .Range("A1").End(xlDown).Row
For x = 1 To Numrows ' Establish "For" loop to loop "numrows" number of times
vVal1 = .Cells(x, 8)
vVal2 = .Cells(x, 7)
' change "Sheet2" to your sheet's name in "Purchasing List.xls" file where you are looking for vVal1
Set FindRng = PurchaseWb.Sheets("Sheet2").Cells.Find(What:=vVal1, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
If Not FindRng Is Nothing Then '<-- make sure Find was successful finding vVal1
' write to Qty cell beside the found name ActiveCell.Offset(0, -2) = vVal2
' Not sure eactly what you want to do now ???
Else ' raise some kind of notification
MsgBox "Unable to find " & vVal1, vbInformation
End If
Next x
End With
Application.ScreenUpdating = True
End Sub
Edited to account for OP's comment about where to search and write values
ShaiRado already told you where the flaw was
here's an alternative code
Option Explicit
Sub Macro1()
Dim cell As Range, FindRng As Range
Dim purchListSht As Worksheet
Set purchListSht = Workbooks("Purchasing List.xls").Worksheets("purchaseData") '(change "purchaseData" to your actual "purchase" sheet name)
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Workbooks("to_update_example_1").Sheets("SourceData") ' reference your "source" worksheet in "source" workbook (change "SourceData" to your actual "source" sheet name)
For Each cell In .Range("H1", .Cells(.Rows.Count, 8).End(xlUp)).SpecialCells(xlCellTypeConstants) ' loop through referenced "source" sheet column "H" not empty cells
Set FindRng = purchListSht.Columns("G").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns) ' try finding current cell content in "purchase" sheet column "G"
If Not FindRng Is Nothing Then FindRng.Offset(, -2).Value = cell.Offset(, -1).Value ' if successful, write the value of the cell one column left of the current cell to the cell two columns to the left of found cell
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have an excel workbook where an unknown amount of data from text files can be imported (the user will import as many text files as they feel necessary). I am attaching an identifier (1, 2, 3, etc) each time a text file is imported to the workbook. On the "Information Sheet" I have a form control combobox where the user selects the "initial data set" aka (1, 2, 3, etc) by selecting the identifier value from the dropdown. What I want to happen is when the user selects a value to specify the initial data set, this data set will get highlighted in grey on the "Data Importation Sheet" aka the sheet where all the data gets imported to. I think my code is close but it isnt working.
Here is my code for the Combobox:
Private Sub ComboBox1_Change()
Call Find_Initial_Data_Set
End Sub
And here is my code for highlighting the data in the "Data Importation Sheet" according to the value in cell E12 where my Combobox is located:
Sub Find_Initial_Data_Set()
Dim ws As Worksheet
Dim aCell As Range
Dim aCell1, aCell2, aCell3 As Range
Dim NewRange As Range
Dim A As String
Dim LastRow As Integer
Worksheets("Information Sheet").Activate
If Range("E12").Value <> "" Then
Set ws = Worksheets("Data Importation Sheet")
A = Worksheets("Information Sheet").Range("E12").Value
Worksheets("Data Importation Sheet").Activate
With ws
Set aCell = .Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
LastRow = Worksheets("Data Importation Sheet").Cells(Rows.Count, "A").End(xlUp).Offset(-1).Row
With ws
Set aCell1 = aCell.Offset(0, -1)
Set aCell2 = aCell.Offset(LastRow, 5)
Debug.Print aCell1.FormulaR1C1
Debug.Print aCell2.FormulaR1C1
Set NewRange = .Range(aCell1.Address & ":" & aCell2.Address)
Debug.Print NewRange.Address
End With
NewRange.Interior.ColorIndex = 15
Else
End If
End Sub
Here are some visuals of my excel book:
Data Importation Sheet where the data gets input (you cannot see the identifier in this pic but beneath the data I have a cell that says Identifier with the corresponding importation value beside it):
Information Sheet where the user selects the initial data set based on identifier:
And this is what I would like the Data Importation Sheet to look like after the user selects 1 (for example) for the initial data set:
Any advice would be greatly appreciated!
the code would be like this.
sheet's code
Private Sub ComboBox1_Change()
Call Find_Initial_Data_Set(ComboBox1.Text)
End Sub
module code
Sub Find_Initial_Data_Set(A As String)
Dim Ws As Worksheet
Dim aCell As Range, NewRange As Range
Dim LastRow As Integer
Set Ws = Worksheets("Data Importation Sheet")
With Ws
If A <> "" Then
Set aCell = .Rows(1).Find(what:=A, after:=.Range("a1"), LookIn:=xlValues, lookat:=xlPart)
If aCell Is Nothing Then
Else
Set aCell = aCell.Offset(, -1)
LastRow = .Range("a" & Rows.Count).End(xlUp).Row
Set NewRange = aCell.Resize(LastRow, 7)
NewRange.Interior.ColorIndex = 15
End If
End If
End With
End Sub
i rewrote your code somewhat
please single-step through code using F8 key
check if correct ranges are "selected" at "debug" lines
please update your post with findings
i suspect that the wrong cells are being referenced once the worksheet is partially populated
also, please refrain from using: ( ... this means, anyone reading this)
With ws
Set aCell = .Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
use this:
Set aCell = ws.Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
it is shorter and more readable
use "with" convention only if it really simplifies the code a lot
see the end of the code for info that may help you
Sub Find_Initial_Data_Set()
Dim infoSht As Worksheet
Dim dataImpSht As Worksheet
Dim aCell As Range
' Dim aCell1, aCell2 As Range ' do not use ... aCell1 is declared as variant. not as range
Dim aCell1 As Range, aCell2 As Range, aCell3 As Range
Dim NewRange As Range
Dim A As String
Dim LastRow As Integer
Set dataImpSht = Worksheets("Data Importation Sheet")
Set infoSht = Worksheets("Information Sheet")
A = infoSht.Range("E12").Value
If A <> "" Then
Set aCell = dataImpSht.Rows(1).Find(What:=A, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
dataImpSht.Activate ' debug .Select command fails if sheet is not visible
aCell.Select ' debug (this should highlight "aCell")
dataImpSht.Cells(dataImpSht.Rows.Count, "A").Select ' debug
dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Select ' debug
dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(-1).Select ' debug
dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(1).Select ' debug
LastRow = dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(-1).Row
aCell.Select ' debug
aCell.Offset(0, -1).Select ' debug
aCell.Offset(LastRow, 5).Select ' debug
Set aCell1 = aCell.Offset(0, -1)
Set aCell2 = aCell.Offset(LastRow, 5)
aCell1.Select ' debug
aCell2.Select ' debug
Debug.Print aCell1.FormulaR1C1
Debug.Print aCell2.FormulaR1C1
Set NewRange = dataImpSht.Range(aCell1.Address & ":" & aCell2.Address)
NewRange.Select ' debug
Debug.Print NewRange.Address
NewRange.Interior.ColorIndex = 15
End If
'---------------------------------------------------------------------------
' check this out ... it may be what you need to use
Dim aaa As Range
Set aaa = dataImpSht.Cells(dataImpSht.Rows.Count, "A").End(xlUp).Offset(1)
aaa.Select
aaa.Range("a1").Select ' aaa can be thought off as the new top left corner
aaa.Range("b2").Select ' you can refer to cells in relation to aaa
Set aaa = aaa.Offset(4) ' and move position of aaa for each iteration
aaa.Range("a1").Select
aaa.Range("b2").Select
'---------------------------------------------------------------------------
End Sub
You need to change LastRow to the following as all you need is the row number:
LastRow = Worksheets("Data Importation Sheet").Cells(Rows.Count, "A").End(xlUp).Row - 1
I have the code below and works fine, but I only want to copy cells with Values. I have blank data in the middle, as I will delete that does not make sense to copy them too.
Sub FindAgain()
'
' FindAgain Macro
'
Dim Ws As Worksheet
Dim LastRow As Long
AC = ActiveCell.Column
Set Ws = Worksheets("Sheet1")
LastRow = Ws.Cells(Rows.Count, "B").End(xlUp).Row
Cells.Find(What:="Scenario", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, Cells(LastRow, AC)).Select
End Sub
Any idea how I can better write it? With Loop maybe? Thanks!
I assume that after Range(ActiveCell, Cells(LastRow, AC)).Select you see a region selected that you want to copy ignoring blank cells. One way to go about it is to iterate over all the cells in Selection, check if they are not empty and copy them:
Dim c As Range
Dim i As Long
' store current row for every column separately
Dim arrRowInCol() As Long
ReDim arrRowInCol(Selection.Column To Selection.Column + Selection.Columns.Count - 1)
For i = LBound(arrRowInCol) To UBound(arrRowInCol)
' init the first row for each column
arrRowInCol(i) = Selection.Row
Next i
For Each c In Selection
If Len(Trim(c)) <> 0 Then
c.Copy Destination:=Sheets("Sheet2").Cells(arrRowInCol(c.Column), c.Column)
arrRowInCol(c.Column) = arrRowInCol(c.Column) + 1
End If
Next c
Found a way to do what I want: At least is working, i am newby so, for you guys may seem funny or bad, for me is great =D
Sub FindAgain()
'
' FindAgain Macro
'
Dim Ws As Worksheet
Dim LastRow As Long
Dim c As Range
Dim i As Integer
Dim j As Integer
AC = ActiveCell.Column
Set Ws = Worksheets("Sheet1")
LastRow = Ws.Cells(Rows.Count, "B").End(xlUp).Row
i = 15
j = 7
Cells.Find(What:="Scenario", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, Cells(LastRow, AC)).Select
For Each c In Selection
If Len(Trim(c)) <> "" Then
c.Copy Destination:=Sheets("Sheet1").Cells(i, j)
End If
If c = "" Then
i = i
Else
i = i + 1
End If
j = j
Next c
End Sub
I will start with your code, which actually tries to select the ranges. This is what I have built upon it:
Option Explicit
Public Sub FindMe()
Dim my_range As Range
Dim temp_range As Range
Dim l_counter As Long
Dim my_list As Object
Dim l_counter_start As Long
Set my_list = New Collection
l_counter_start = Cells.Find(What:="Scenario", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Row + 1
For l_counter = l_counter_start To Worksheets("sheet1").Cells(Rows.Count, "B").End(xlUp).Row
If Cells(l_counter, 2) <> "" Then my_list.Add (l_counter)
Next l_counter
For l_counter = 1 To my_list.Count
Set temp_range = Range(Cells(my_list(l_counter), 2), Cells(my_list(l_counter), 4))
If my_range Is Nothing Then
Set my_range = temp_range
Else
Set my_range = Union(my_range, temp_range)
End If
Next l_counter
my_range.Select
End Sub
It works upon a scenario like this:
Pretty much it works like this:
We declare two ranges.
The range my_range is the one to be selected at the end.
The range temp_range is only given, if there is a value in the second column.
Then there is a union of both ranges, and my_range is selected at the end of the code.
I would like to ask if you can help with the code below. On every sheet in my workbook there is the same kind of a table, however on each sheet the table has different location and values. I need to go through all sheets, search for table values on every sheet and then do some other operations with the values. I use Find function to determine header of the table and subsequently table range. The Find function does not work properly though as it keeps found address of "Header" cell from the first sheet for every other sheet. Is there any way to reset the found header address value before looping to another sheet? Thank you in advance.
Sub FindInDynamicRanges()
Dim wb1 As Workbook
Dim ws As Worksheet
Dim FoundCell, FoundTab, TabEntries As Excel.Range
Dim FirstAddr As String
Dim FirstRow, LastRow As Long
Set wb1 = ThisWorkbook
'Find all occurences of any table value on all sheets in dynamic ranges
For Each ws In wb1.Worksheets
Set ws = ActiveSheet
'Find "Header" cell
Set FoundCell = ws.Columns(2).Find(What:="Header", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
MsgBox FoundCell.Address
'Set number of first entry row and last entry row
FirstRow = FoundCell.Row + 1
LastRow = ws.Cells.Find(What:="*", After:=Range("A1"), LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
ws.Range("B" & FirstRow & ":B" & LastRow).Name = "TabEntries"
MsgBox Range("TabEntries").Address
With ws.Range("TabEntries")
Set LastCell = .Cells(.Cells.Count)
End With
Set FoundTab = ws.Range("TabEntries").Find(What:="*", After:=LastCell, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not FoundTab Is Nothing Then
FirstAddr = FoundTab.Address
End If
Do Until FoundTab Is Nothing
'do some staff with found values
Set FoundTab = ws.Range("TabEntries").FindNext(After:=FoundTab)
If FoundTab.Address = FirstAddr Then
Exit Do
End If
Loop
Next ws
End Sub
as it keeps found address of "Header" cell from the first sheet for every other sheet.
That is because you are telling it to...
For Each ws In wb1.Worksheets
Set ws = ActiveSheet
You don't need that Set ws = ActiveSheet
When you say For Each ws, the ws is automatically initialized. So just remove the second line.