my problem is related to the importation of data, when I do this action trough a macro linked to a button, the data from the other file comes into the target workbook and disrupts all the previous cell format there. It is like it transfers the same format from the source sheet that the data comes from.
I will post my code and if it isn't enough I will post the workbooks.
Sub ImportData()
Application.ScreenUpdating = False
Dim Path As String, Lstrw As Long
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Path = "C:\Users\DZPH8SH\Desktop\Status 496 800 semana 12 2015.xls" 'Para modificar ter acesso a pasta onde irá ficar o ficheiro
Set SourceWb = Workbooks.Open(Path)
Set TargetWb = ThisWorkbook
Dim n As Integer, targetRow As Long
targetRow = 3
'Para importar os sheets que o utilizador quiser, modifique o n "="
For n = 1 To 2
With SourceWb.Sheets(n)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy Destination:=TargetWb.Sheets(7).Range("A" & targetRow)
'move the targetRow to the first empty row after pasting the source data
targetRow = targetRow + Lstrw
End With
Next
SourceWb.Close savechanges:=False
Application.ScreenUpdating = True
End Sub
Thanks for any reply in advance.
You are just doing a straight copy/paste, which will copy formats and values. There are two options for just bringing through values (which I assume is what you want).
The first is to use Range.Copy to copy cells to the clipboard and then Range.PasteSpecial(xlPasteValues) to just paste the values:
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Range("A" & targetRow).PasteSpecial(xlPasteValues)
The second option is to use the Value property to get and set cell values without affecting formats. In this case you would have to modify your loop as you can't get all the values from a non-contiguous range in one statement (the Value property just returns the values from the first area in an array). You would do something like:
targetColumn = 1
For Each sourceArea In .Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Areas
TargetWb.Sheets(7).Range(TargetWb.Sheets(7).Range.Cells(targetRow, targetColumn), TargetWb.Sheets(7).Range.Cells(targetRow, targetColumn + Lstrw - 1)).Value = sourceArea.Value
targetColumn = targetColumn + 1
Next sourceArea
This is conceptually simple (targetRange.Value = sourceRange.Value) but looks ugly because of having to loop through areas, and construct the equivalent target range with the right number of cells. But it is more flexible than the first option, and there probably are neater ways of getting the right target ranges.
Related
The below code, when a user logs an issue into a form, will log in the appropriate issue tab.
Once the team has completed the issue and marks it as "Complete & Verified", I want to move that issue (row) out of the current tab into the "5. Complete & Verified" tab.
The issue is, say there are 9 rows of data in the current tab, the macro is pasting the row into the 9th row of the "5. Complete & Verified" tab.
I am trying to paste one after the other starting in B2. I am also trying to Paste the tab name into column 1 (column A) as an identifier.
Sub Complete()
ActiveSheet.Activate
Dim objWS As Worksheet
Set objWS = ActiveSheet
Dim intLastRowSrc As Long
intLastRowSrc = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
ActiveSheet.Activate
Dim intLastRowSDes As Long
intLastRowSDes = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
Dim r As Long
For r = 2 To intLastRowSrc
If objWS.Cells(r, "R") = "Complete & Verified" Then
Sheets("5. Complete & Verified").Range("B" & intLastRowSDes & ":T" & intLastRowSDes).Value = objWS.Range("A" & r & ":S" & r).Value
objWS.Rows(r).Delete
Sheets("5. Complete & Verified").Cells(intLastRowSDes, 1) = ws1.Name
intLastRowSrc = intLastRowSrc - 1
intLastRowSDes = intLastRowSDes + 1 'Issue - I need it to paste into next row with now data in 5. tab
End If
Next
Exit Sub
There are a few things that need adjusted to work as (I think) you want things to work.
Firstly, set references to the source and destination worksheets and use them directly rather than naming each time.
Secondly you don't need to Activate any of the worksheets, so let's remove those
Thirdly if you are looking to delete rows within a for loop, always start at the bottom of your data range and move up- otherwise when you delete row 21 and 22 moves up, your loop will completely ignore the fact that 22 moved up without getting checked and you will miss rows
Fourthly, just grab the destination row from inside the loop rather than try to increment the count
Fifthly, you are setting column 1 on your destination sheet to ws1.name but you never define it, so I've replaced that with a reference to the source worksheet name.
If any of this doesn't make sense, drop a comment below and I'll try to explain better.
Sub Complete()
Dim sourceWS As Worksheet
Set sourceWS = ActiveSheet
Dim destWS As Worksheet
Set destWS = ThisWorkbook.Worksheets("5. Complete & Verified")
Dim intLastRowSrc As Long
intLastRowSrc = sourceWS.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Dim intLastRowSDes As Long
Dim r As Long
For r = intLastRowSrc to 2 Step -1
If sourceWS.Cells(r, "R") = "Complete & Verified" Then
intLastRowSDes = destWS.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
destWS.Range("B" & intLastRowSDes & ":T" & intLastRowSDes).Value = sourceWS.Range("A" & r & ":S" & r).Value
sourceWS.Rows(r).Delete
destWS.Cells(intLastRowSDes, 1) = sourceWS.Name
End If
Next
Exit Sub
Michael,
Dave posted his answer while I was working on it. While it will work, if I'm not mistaken, and that may well be the case, the items will be copied in reverse order to the new destination sheet. If order is important you may what to try using a Do/Loop as follows:
Option Explicit
Sub Complete()
Dim lRow As Long
Dim shtWS As Worksheet
Dim shtDest As Worksheet
Dim lLastRowSDes As Long
'*** Don't use ActiveSheet rather specify the name
'*** If called from more than one sheet pass as parameter.
Set shtWS = WorkSheets("your sheet name here")
set shtDst = Worksheets("5.Complete & Verified")
lLastRowSDes = ActiveSheet.Cells.Find("*", _
searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row + 1
lRow = 2 'Set Starting Row
Do
If shtWS.Cells(lRow, "R") = "Complete & Verified" Then
shtWS.Range("B" & lRow & ":T" & lRow).Copy
shtDst.Range("B" & lLastRowSDes).Paste
shtWS.Rows(lRow).Delete
'*** Note we don't increment counter as next row moves up to current lRow position!
shtDst.Cells(lLastRowSDes, 1) = shtWS.Name
lLastRowSDes = lLastRowSDes + 1
Else
lRow = lRow + 1 'Increment Row Counter
End If
Loop Until (shtWS.Cells(lRow,"B").Value = "")
You'll notice I used Copy/Paste as I've never seen the syntax of assigning one range to another like that, very neat! So you could just replace the copy/paste lines with that one.
FYI: code not tested!
HTH
I have a file (called original) that has partially information for each row. Each row has a file name column (from where information is to be captured from).
For each row I'd like to open up the file in the file name column, and grab information from certain rows.
In the file it is only one column, with rows "Supplier Number : _____", the location of this row is variable, so I'd like to iterate through each row in the file to copy this cell value and paste it into the original file in the corresponding row.
This is what I have so far:
Const FOLDER_PATH = "C:\Users\[user]\Downloads\"
Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim source As String
Dim target As String
Dim update As String
Dim rowT As Integer
rowT = 2
rowTT = 1
Dim rowRange As Range
Dim colRange As Range
Dim rowRangeT As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowT As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A2:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
source = FOLDER_PATH & wks.Cells(i, 18).Value 'the name of the file we want to grab info from in this Column, always populated
'if the cell is empty, search through the file for "Supplier Number : "
If IsEmpty(wks.Cells(rowT, 19)) Then
Set wb = Workbooks.Open(source)
wb.Activate
LastRowT = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = wks.Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
Range("A" & rowTT).Select
Selection.Copy
Windows("Get Supplier Number.xlsm").Activate
Range("A" & rowT).Select
wks.Paste
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
Next rrow
ScreenUpdating = True
End Sub
I get the pastespecial error 1004.
What is expected is that for each row in "Get Supplier Number.xlsm", the row's A column is updated with the information
Thank you for helping!
First of all you should get rid of Activate and Select methods. You don't have to use them and they give nothing to your code. Using them is not a good approach.
To avoid them you should use specific references. Which you are doing so, until a specific point. Inside the for loop, after setting the wb, replace everything with the following:
With wb.Worksheets(1)
LastRowT = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = .Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
.Range("A" & rowTT).Copy wks.Range("A" & rowT)
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
End With
I think this should do the job for you.
PS: If you need just the value of the cell in the opened workbook, then you could replace the Copy line with a simple equality:
wks.Range("A" & rowT) = .Range("A" & rowTT)
I have working code that checks for a criteria in each row, and if met, copies that whole row of data over to a different workbook. But! I need to be able to add text to the last column of the copied data (Column S) that essentially labels what criteria was met that made the code copy it over because I will soon be expanding to check for multiple different criteria.
So for every row that meets the criteria and gets copied, I want to add "Criteria1" next to it in column S in the new workbook (it will always be column S that will be the first available column).
I have mangled this code together through inheritance and all of your help, so I don't really even know where to begin.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim CoderBook As Workbook
Dim Referrals As Worksheet
Dim Review As Workbook
Dim Crit As Worksheet
Dim LastRow As Long
Dim NextRow As Long
Dim i As Long
Set CoderBook = Workbooks.Open("Coder Referrals.xlsx")
Set Referrals = CoderBook.Sheets("Sheet1")
Set Review = ThisWorkbook
Set Crit = Review.Sheets("Criteria")
'Search code
LastRow = Crit.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
'Loop search code
For i = 2 To LastRow
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Or _
Crit.Range("I" & i) <> Crit.Range("J" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.Value = Crit.Rows(i).Value
End If
Next i
'End loop code
CoderBook.Close SaveChanges:=True
Application.ScreenUpdating = True
End Sub
Split the or into two statements:
For i = 2 To LastRow
j = Referrals.Cells(Rows.Count, 1).End(xlUp).row + 1
'Specialized Criteria1 Check
If Crit.Range("F" & i) <> Crit.Range("G" & i) Then
'If meets Criteria1 check, then copy appropriate rows to CoderBook Referrals sheet
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
Referrals.Range("S" & j).Value = "Criteria1"
End If
If Crit.Range("I" & i) <> Crit.Range("J" & i) Then
Referrals.Rows(j).EntireRow.Value = Crit.Rows(i).Value
if Referrals.Range("S" & j).value = vbNullString then
Referrals.Range("S" & j).Value = "Criteria2"
Else
Referrals.Range("S" & j).Value = Referrals.Range("S" & j).Value & ", " & "Criteria2"
End if
Next i
I have folders and sub-folders like this 8 layers and 500K records in one sheet:
C:\999\236\857\871
C:\999\234\567\874
C:\999\234\567\873
C:\999\234\586\396
C:\999\234\566\458
In Test worksheet Column A has data
236857871
234567874
234567873
234586396
234566458
I wanted to create a macro to create a hyperlink on the existing data in Column A so that when I click on the data, the respective folder would open. I grafted a macro from one that was available in StackOverflow below. It creates only one destination...it could not create a link for respective records. Can I get help?
Sub HyperlinkNums ()
Dim WK As Workbooks
Dim sh As Worksheet
Dim i As Long
Dim lr As Long
Dim Rng As Range, Cell As Range
Set sh = Workbooks("Bigboss.xlsm").Sheets("Test")
lr = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
Set Rng = sh.Range("A5:A" & lr)
sh.range("A5").Activate
For i = 7 To lr
For Each Cell In Rng
If Cell.Value > 1 Then
sh.Hyperlinks.Add Anchor:=Cell, Address:= _
"C:\999\" & Left(ActiveCell, 3) & "\" & _
Mid(ActiveCell, 4, 3) & "\" & Mid(ActiveCell, 7, 3) & "\" & _
Right(ActiveCell, 3), TextToDisplay:=Cell.Value
End If
Next Cell
Next
End Sub.
So, the largest issue in your code is that you are always referring to the ActiveCell. You are using a For Each...Next loop, and you should be using the rng object that you are looping.
You also have a redundant loop: For i = 7 To lr. You can get rid of this.
And I am not a big fan of using semi-reserved keywords as variables, so I slightly renamed the cell variable to cel. I think this may be what you are looking for:
Option Explicit
Sub HyperlinkNums()
Dim WK As Workbooks
Dim sh As Worksheet
Dim lr As Long
Dim Rng As Range, Cel As Range
Set sh = Workbooks("Bigboss.xlsm").Sheets("Test")
lr = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
Set Rng = sh.Range("A5:A" & lr)
sh.Range("A5").Activate
For Each Cel In Rng
If Cel.Value > 1 Then
sh.Hyperlinks.Add Cel, "C:\999\" & Left(Cel.Text, 3) & "\" & _
Mid(Cel.Text, 4, 3) & "\" & Right(Cel.Text, 3), _
TextToDisplay:=Cel.Text
End If
Next Cel
End Sub
Also, I was slightly confused about the usage of Mid(ActiveCell, 7, 3), which it appeared to have the same meaning to Right(ActiveCell, 3). I removed that portion.
I've got a sample table in Sheet1 as below:
Location Model Part #
BF03 200W 40536573
BF04 200W 40536573
CV01 120W 40536585
CV02 135W 20085112
CV03 900W 20349280
CV04 135W 20085112
As a reference data of BF03 is in cell B6.
What I need it to do is:
A) When user typed part number (ex: 40536573) in Sheet3 say cell A1, only the matched location will be picked up
B) The picked up "location" value will be tabulated in Sheet2 starting from cell A6.
The output will look something like this:
Location Model Part #
BF03 200W 40536573
BF04 200W 40536573
To make matter more complicated, I would then need to have the "Location" data to be concatenated into a string and store it in Sheet 2 Cell A2.
I'm guessing we need to do a For Loop count rows but I couldn't get any reference on how to write it properly.
Below are what my error "OVERFLOW" code looks like
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim FindMatch As String
Dim Rng As Range
Dim counter As Integer
counter = ActiveWorkbook.Worksheets("Sheet2").Range("A6", Worksheets("Sheet2").Range("A6").End(xlDown)).Rows.Count
For i = 6 To counter
'Get the value from other sheet set as FindMatch
FindMatch = Sheets("Sheet3").Cell("A1").Value
'Find each row if matches the desired FindMatch
If Trim(FindMatch) <> "" Then
With Sheets("Sheet2").Range("D" & i).Rows.Count
Set Rng = .Find(What:=FindMatch, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
'copy the values required to the cell
Cells(i, 2) = Sheets("Sheet2").Cells(Rng.Row, 2)
Else
MsgBox "Nothing found"
End If
End With
End If
Next i
End Sub
Instead of using the .find method, I managed to use a simple for loop. Sometimes you need to think simple i guess :) I have also added a small function to clear previously used fields. If you check and give feedback if you face any problem, we can try to fix it.
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim S_Var As String
Dim copyRange As Range
Dim ws1_lastrow As Long
Dim ws2_lastrow As Long
Dim searchresult As Range
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")
S_Var = ws3.Range("A1").Value
ws1_lastrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
Set copyRange = ws1.Range("A1:C" & ws1_lastrow)
'Clear Data
ws2.Range("A2").Value = ""
If Range("A7").Value <> "" Then
ws2.Range("A7:C" & ws2.Range("A" & ws1.Rows.Count).End(xlUp).Row).Value = ""
End If
'Searchin through the sheet1 column1
For i = 2 To ws1_lastrow
If ws1.Range("C" & i) = S_Var Then
ws2_lastrow = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
ws1.Range("A" & i & ":C" & i).Copy Destination:=ws2.Range("A" & ws2_lastrow + 1)
End If
Next
'Adding location to sheet2 A2 as string
ws2_lastrow = ws2.Range("A" & ws1.Rows.Count).End(xlUp).Row
For i = 7 To ws2_lastrow 'starting from 7, where location starts
If ws2.Range("A2").Value = "" Then
ws2.Range("A2").Value = ws2.Range("A" & i).Value
Else
ws2.Range("A2").Value = ws2.Range("A2").Value & "," & ws2.Range("A" & i).Value
End If
Next