My first post here.....
I was able to search and find this code from Siddharth Rout which is the basis for what I want to do....append multiple sheets of data to a single data sheet. However I'm having trouble modifying it to fit my case. What I have below doesn't currently work......
Problem 1) How can I use Select Case InStr with multiple sheets (3) that do not have a common name such as "Legende" as the original poster had in her case.
Problem 2) In my case each sheet will have different columns that I need copied to the Tab_Appended sheet, Sheet1 will have x rows and I want column B, D, M, AR, etc and Sheet2 will have XXXX rows and I want to copy column B, D, N, AS, AT, etc for 15 sheets.
Credit to Siddharth Rout for this original code:
Sub SummurizeSheets()
Dim wsOutput As Worksheet
Dim ws As Worksheet
Dim wsOLr As Long, wsLr As Long
Application.ScreenUpdating = False
'~~> Set this to the sheet where the output will be dumped
Set wsOutput = Sheets("Tab_Appended")
With wsOutput
'~~> Get Last Row in "Tab_Appended" in Col A/M and Add 1 to it
wsOLr = .Range("A:M").Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row + 1
'~~> Loop through sheet
For Each ws In Worksheets
'~~> Check if the sheet name has Legende
'Select Case InStr(1, ws.Name, "Legende", vbTextCompare)
Select Case InStr(1, ws.Name, "Test2", vbTextCompare) + _
InStr(1, strData, "Test", vbTextCompare) + _
InStr(1, strData, "Sheet2", vbTextCompare)
'~~> If not then
Case 0
With ws
'~~> Get Last Row in the sheet
wsLr = .Range("A:M").Find(What:="*", After:=.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
'~~> Copy the relevant range
.Range("A2:M" & wsLr).Copy wsOutput.Range("A" & wsOLr)
'~~> Get Last Row AGAIN in "Tab_Appended" in Col A/B and Add 1 to it
wsOLr = wsOutput.Range("A:M").Find(What:="*", After:=wsOutput.Range("A1"), _
Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row + 1
End With
End Select
Next
End With
Application.ScreenUpdating = True
End Sub
Thanks,
Don
Related
I am trying to select a range until the last used row in the sheet. I currently have the following:
Sub Select_Active_Down()
Dim lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
If Cells(ActiveCell.Row, ActiveCell.Column) = Cells(lr, ActiveCell.Column) Then
MsgBox "There isn't any data to select."
Else
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(lr, ActiveCell.Column)).Select
Cells(lr, ActiveCell.Column).Activate
End If
End Sub
The issue is that I need to select multiple columns, and this will only select the first column of the active range. How can I modify this to select multiple columns rather than just the first?
What about selection the entire region? This can be done as follows in VBA:
Selection.CurrentRegion.Select
There also is the possibility to select the entire array. For that, just press Ctrl+G, choose Special and see over there.
I would do this slightly different. I would use .Find to find the last row and the last column (using the same logic shown in the link) to construct my range rather than using Selection | Select | ActiveCell | UsedRange | ActiveSheet.
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim LastColumn As Long
Dim rng As Range
'~~> Change it to the relevant sheet
Set ws = Sheet1
With ws
'~~> Check if there is data
If Application.WorksheetFunction.CountA(.Cells) = 0 Then
MsgBox "No Data Found"
Exit Sub
End If
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Work with the range
With rng
MsgBox .Address
'
'~~> Do what you want with the range here
'
End With
End With
End Sub
Trying to copy data from one Excel spreadsheet to another (from New_data to report).
In the New_data spreadsheet I find the second time System (hence why I start the search below the first one at N21) appears then I need to copy all data below it from columns b - k until I hit blank cells. How do I get the amount of rows to only capture filled cells?
Range("B584:K641") needs to be dynamic.
Sub CopyWorkbook()
Range("N21").Select
Cells.Find(What:="system", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B584:K641").Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv"). _
Activate
End Sub
Try the next code please. It should be very fast (if I correctly understood where to be searched for 'system', starting with what...). The code assumes that "new_data.csv" is the csv workbook name. If not, you must use its real name when defining shCSV sheet:
Sub CopyWorkbook()
Dim shR As Worksheet, shCSV As Worksheet, lastRow As Long, systCell As Range, arr
Set shR = Workbooks("report.xlsx").ActiveSheet 'use here the sheet you need to paste
'it should be better to use the sheet name.
'No need to have the respective sheet activated at the beginning
Set shCSV = Workbooks("new_data.csv").Sheets(1) 'csv file has a single sheet, anyhow
lastRow = shCSV.Range("B" & rows.count).End(xlUp).row
Set systCell = shCSV.Range("B21:B" & lastRow).Find(What:="system", _
After:=shCSV.Range("B21"), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If systCell Is Nothing Then MsgBox "No 'sytem' cell has been found...": Exit Sub
arr = shCSV.Range(systCell, shCSV.Range("K" & lastRow)).Value
shR.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
Try:
Sub test()
Dim LR As Long
Dim Ini As Long
LR = Range("B" & Rows.Count).End(xlUp).Row 'last non empty row in column B
Ini = Application.WorksheetFunction.Match("system", Range("N21:N" & LR), 0) + 20 'position of system after n21
Range("B" & Ini & ":K" & LR).Copy
'''rest of your code to paste
End Sub
Note that this code is searching word system only in column N. If it's somewhere else, you'll need to adapt the MATCH function
I set a range to equal the filtered range and start a loop to count how many none empty cells occur until the first empty cell in column B.
Sub CopyWorkbook()
ThisWorkbook.Sheets("new_data").Activate
Range("N21").Select
Dim rng As Range
Set rng = Cells.Find(What:="system", After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
Dim i As Double
i = rng.Row
Do Until ThisWorkbook.Sheets("new_data").Range("B" & i) = vbNullString
i = i + 1
Loop
i = i - 1
Range("B" & rng.Row & ":K" & i).Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv").Activate
End Sub
I found a Stack Overflow question that was helpful in finding an answer. Find cell address
I'm so new to vba that I have searched for this topic and though I have found similar questions I'm still having a hard time understanding the formulas so I hope someone can help.
I want to search Column B in all worksheets in my workbook for any cell that contains "Disc" within its text. I then want to copy and paste all the info from the row that it is found in, or if not the entire row, at the very least the info in columns B & C.
This is what I have tried so far but when I get to Select B:B, it is selecting the column on my "Discs" sheet instead of the worksheets it should be looping through.
Sub DiscFill()
'
'
' Keyboard Shortcut: Ctrl+Shift+D
Dim DiscsSh As Worksheet
Dim sh As Worksheet
Dim I As Integer
'add new sheet at the end'
Set DiscsSh = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'rename it'
DiscsSh.Name = "Discs"
'loop through all sheets'
For Each sh In Worksheets
'if sh is not Discs sheet, then'
If sh.Name <> DiscsSh.Name Then
'Select Column Range and Search for Discs
Columns("B:B").Select
Cells.Find(What:="Component Discs", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
'Finds Row from Search and Adds 1 to start in the correct Row/sku#
startRow = Selection.Row + 1
'Go back to new sheet to start inputing data
Sheets("Discs").Select
'this tells you how far you can potentially go
For j = startRow To 999
'if blank cell then the loop stops
If Sheets(I).Cells(j, 3).Value = "" Then
Exit For
Else
mat_num = Sheets(I).Cells(j, 3).Value
TitleDescrip = Sheets(I).Cells(j, 2).Value
Cells(counter, 1).Value = mat_num
Cells(counter, 2).Value = TitleDescrip
counter = counter + 1
End If
Next j
End If
Next
End Sub
Hi #SDension modified code hope this works
mention sheet obj.
sh.Columns("B:B").Select
sh.Cells.Find(What:="Component Discs", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Select
I have a table that ranges from "A:EV".
I want to find the last row of only range "A:DD".
The columns might have blank cells, so I need to go through all and find the furthest row of columns A to DD.
How can I code it?
Modified from HERE
Sub foo()
With Sheets("Sheet9") 'Change to your sheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
'Used 1000 to prove that it was not defaulting to this.
'Change to 1 when using in actual code.
lastrow = 1000 'Change to 1 when using.
End If
MsgBox lastrow
End With
End Sub
And to adjust the range a bit, change the two column letters in these two lines.
This one searches over columns A:DD.
lastrow = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
This version narrows the search range to Y:DD
lastrow = .Range("Y:DD").Find(What:="*", _
After:=.Range("Y1"), _
And with a little voodoo, if you are interested in also getting the column where the last row was found but don't want to extract it from .Address, use this.
sub voodoo()
Dim theresult As Variant
With Sheets("Sheet9") 'Change to your sheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Set theresult = .Range("Y:DD").Find(What:="*", _
After:=.Range("Y1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
Else
'Used 1000 to prove that it was not defaulting to this.
'Change to 1 when using in actual code.
lastrow = 1000 'Change to 1 when using.
End If
MsgBox ("LastRow " & theresult.Row & " column " & theresult.Column)
End With
End Sub
Microsoft Excel 2010:
From month to month, the number of lines of data can be variable. When I paste new data into the ILS_IMPORT tab, there may be 3,500 records and the next month could be 2,500. When I go to import the data into Access, and extra 1,000 lines will appear unless I delete all records from line 2,501 on. I would like to have Excel VBA to do this and have made attempts, but nothing has worked thus far. I know that Column O will always have data to the end because it is the quarter indicator (ex. Q2).
However, this code keeps deleting the last row and I don't know if it is truly deleting all the way to the end. Can someone point me in the right direction?
Sub test()
Dim rng As Range
Dim lastRow As Long
With ThisWorkbook.Sheets("ILS_IMPORT")
'Find anything in the cells
Set rng = .Cells.Find(What:="*", _
After:=.Range("O1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
'if data is NOT found - exit from sub
If rng Is Nothing Then Exit Sub
'find last row
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastRow = .Cells.Find(What:="*", _
After:=.Range("O1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastRow = 1
End If
'I use lastRow + 1 to prevent deletion data above when it is on lastrow
.Range(rng.Row + 2 & ":" & lastRow + 2).Delete Shift:=xlUp
End With
End Sub
Could you clear/delete the blank range before you paste data in?
range(cells(2,1),cells(2,1).end(xldown)).EntireRow.Clear