I need to handle an Excel workbook with multiple tabs, and format dates.
I have found a way to format one date, and I wanted to put a loop around it. However the loop does not work, and it only updates one sheet.
Sub dotoall()
Dim LastRow As Integer
Dim FindCol As Range
Dim sAdd As String
Dim ws As Worksheet
For Each Sheet In Worksheets
Set ws = ActiveSheet
With ws
LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'find first instance where DATE exists in row 1 (headers)
Set FindCol = .Rows(1).Find(What:="DTE", LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
'store address of first found instance (to check in loop)
sAdd = FindCol.Address
Do
'format column (row 2 to last used row)
.Range(.Cells(2, FindCol.Column), .Cells(LastRow, FindCol.Column)).NumberFormat = "DD-MM-YYYY"
'find next instance (begin search after current instance found)
Set FindCol = .Cells.FindNext(After:=FindCol)
'keep going until nothing is found or the loop finds the first address again (in which case the code can stop)
Loop Until FindCol Is Nothing Or FindCol.Address = sAdd
End With
Next Sheet
End Sub
Instead of:
For Each Sheet In Worksheets
Set ws = ActiveSheet
You want just:
For Each ws In Worksheets
Related
I have a table of data in a sheet that i am looking to make some adjustments to. I have a single column called "S/R" which will have one of two values in it [Serving OR Returning]. If the value is serving i want to copy the value from a column called "1stServeX" to a new column i have added i called "Server 1st Serve X".
I have written the code below but am beginning to trip myself up and also cannot finish the last part. I am a novice and so have been using other pieces of code i have gained previously to try and piece it together, which is why i need some help.
If i can get this going then i can simply repeat it for all the "Returner" option and all the other columns i need to split too.
Thanks in advance for any help offered.
Public Sub splitServerCoordinates()
'Set a constant for the title of the Server Column
Const HEADER_SR As String = "S/R"
Dim ws As Worksheet
Set ws = Sheets("transition")
Dim strSearch As String
Dim aCell As Range
Dim COL_SR As Long
Dim COL_TARGET As Long
Dim COL_CURRENT As Long
'Find the Column Numbers of the columns we are looking for
strSearch = "S/R"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_SR = aCell.Column
End If
strSearch = "1stServeX"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_CURRENT = aCell.Column
End If
strSearch = "Server 1st Serve X"
Set aCell = ws.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
COL_TARGET = aCell.Column
End If
Dim theUsedRange As Range
Dim SRRange As Range
Dim aPlayer As Range
Dim serving As String
Dim returning As String
Dim theCounter As Long
Dim theSequence As Long
ws.Select
' clear out the Target column and add the header again
Set theUsedRange = ActiveSheet.UsedRange
Intersect(theUsedRange, Range(Columns(COL_TARGET), Columns(COL_TARGET))).ClearContents
Columns(COL_SR).Range("A1").Value = HEADER_SR
' reset the used range just in case
Set theUsedRange = ActiveSheet.UsedRange
' Get the used range for the S/R column
Set SRRange = Intersect(theUsedRange, Columns(COL_SR))
'Set value to compare to
serving = "Serving"
' Loop through the S/R column
For Each aPlayer In SRRange
' ignore the header row
If aPlayer <> HEADER_SR Then
' if we are serving then copy the value from COL_CURRENT to COL_TARGET
If aPlayer = serving Then
aPlayer.Offset(-1, COL_TARGET - COL_).Value = STUCK - HERE
End If
End If
Next aPlayer
End Sub
Some refactoring to pull out the column header location parts, and a few other tweaks. Untested, but should get you there.
Public Sub splitServerCoordinates()
Dim ws As Worksheet, c As Range
Dim COL_SR As Long
Dim COL_TARGET As Long
Dim COL_CURRENT As Long
Set ws = Sheets("transition")
'Find the Column Numbers of the columns we are looking for
COL_SR = HeaderColumnNumber(ws.Rows(1), "S/R")
COL_CURRENT = HeaderColumnNumber(ws.Rows(1), "1stServeX")
COL_TARGET = HeaderColumnNumber(ws.Rows(1), "Server 1st Serve X", True) 'add if not found
'exit if missing any required columns
If COL_SR = 0 Or COL_CURRENT = 0 Then
MsgBox "Missing 'S/R' and/or '1stServeX' !"
Exit Sub
End If
'reset target column
ws.Columns(COL_TARGET).ClearContents
ws.Cells(1, COL_TARGET).Value = "Server 1st Serve X"
'loop rows
For Each c In ws.Range(ws.Cells(2, COL_SR), ws.Cells(ws.Rows.Count, COL_SR).End(xlUp)).Cells
If c.Value = "Serving" Then
ws.Cells(c.Row, COL_TARGET).Value = ws.Cells(c.Row, COL_CURRENT).Value
End If
Next c
End Sub
'Find a header position on a row, with option to add it if not found
' Returns zero if header is not found and option to add was not set
Function HeaderColumnNumber(rng As Range, hdr As String, _
Optional AddIfMissing As Boolean = False) As Long
Dim f As Range
Set rng = rng.Cells(1).EntireRow 'only want a full row to look in
Set f = rng.Find(What:=hdr, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not f Is Nothing Then
HeaderColumnNumber = f.Column 'found: return column
Else
'not found: do we add it, or return zero?
If AddIfMissing Then
With rng.Cells(rng.Cells.Count).End(xlToLeft).Offset(0, 1)
.Value = hdr
HeaderColumnNumber = .Column
End With
Else
HeaderColumnNumber = 0
End If
End If
End Function
I've been struggling with this for a while now.
A1:O7 are frozen columns.
Only the Column A contains trigger values that I find using
Dim Cell As Range
Columns("A:A").Select
Set Cell = Selection.Find(What:="BANK:", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
After that I need to expand the selection so that all the rows and the columns to the right and down from the cell found until the next cell to be found are copied and split into a separate file along with the frozen columns A1:O7 at the top. The range is A7:Oxxxx. There is no data beyond the O column.
Is there a solution to this without using any Excel add-ons?
I tried to understand the task. There are some information missing so this solution might not exactly fitting your needs. I hope it will work for you.
Private Sub Bank()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Bank") 'change according to your workingsheet
Dim rngHeader As Range
Set rngHeader = ws.Range("A1:O7")
Dim iWidth As Integer 'Data and header width
iWidth = rngHeader.Columns.Count
Dim strSearchText As String
strSearchText = "BANK:"
Dim rngSearchArea As Range
Set rngSearchArea = ws.Range(Range("A7"), ws.Range("A" & ws.Range("A:A").Cells.Count).End(xlUp))
Dim strFirstFound As String
Dim rngCurrentFound As Range
Set rngCurrentFound = ws.Range("A7")
Set rngCurrentFound = rngSearchArea.Find(What:=strSearchText, After:=rngCurrentFound, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If rngCurrentFound Is Nothing Then
MsgBox "Nothing found"
Exit Sub
End If
strFirstFound = rngCurrentFound.Address
Dim rngSource As Range
Dim rngNextFound As Range
Do
'Get the position of the next occurence to set the end position
Set rngNextFound = rngSearchArea.FindNext(rngCurrentFound)
If rngNextFound.Row > rngCurrentFound.Row Then
'There is next one
Set rngSource = Range(rngCurrentFound, rngNextFound.Offset(-1)).Resize(, iWidth)
Else
'It was the last one
'If there are data in column A below the last BANK: use the next line
'Set rngSource = ws.Range(rngCurrentFound, Cells(ws.Range("A" & ws.Range("A:A").Cells.Count).End(xlUp), iWidth))
'Use this one to select until the last used cell in the worksheet
Set rngSource = ws.Range(rngCurrentFound, ws.UsedRange.Cells(ws.UsedRange.Cells.Count))
End If
'rngSource.Select
Call Bankcopy(rngSource, rngHeader)
Set rngCurrentFound = rngSearchArea.FindNext(rngCurrentFound)
Loop While rngCurrentFound.Address <> strFirstFound
End Sub
Private Sub Bankcopy(rngSource As Range, ByVal rngHeader As Range)
'Create new book and copy headers
Dim wbNewBook As Workbook
Set wbNewBook = Workbooks.Add()
Dim wsNewSheet As Worksheet
Set wsNewSheet = wbNewBook.Worksheets(1)
Dim rngTarget As Range
'Copy header
Set rngTarget = wsNewSheet.Range("A1") 'To header left upper
rngHeader.Copy
rngTarget.PasteSpecial xlPasteValues
rngTarget.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'Copy data
Set rngTarget = wsNewSheet.Range("A8") 'Data left upper
rngSource.Copy
rngTarget.PasteSpecial xlPasteValues
rngTarget.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
'MsgBox "Test Stop"
'wbNewBook.Close
End Sub
My macro needs to do some calculations on rows and import data where the user enters an ID. Main thing it's running on the specified ID because there is some data that needs updating/doublechecking so running running the entire source file is not ideal.
My code basically asks the user to enter an ID as 'criteria', and then this gets compared with a dictionary I created containing all data from the source, the problem is that using dict.Item doesn't really compare IDs though it runs on every single row correctly in the destination sheet.
'dictionary filler
For indexsrsrow = 2 To indexsrslastrow
dict.Add CStr(srcWorksheet.Range("A" & indexsrsrow).Value), indexsrsrow
Next indexsrsrow
dim criteria as string
criteria = inputbox("enter id")
For indexdstrow = 2 To indexlastdstrow
'IF ID EXIST AND ITEM = CRITERIA AND C COLUMN IS EMPTY
If dict.Exist(criteria) And destinerow.Cells(indexdstrow, "C") = "" Then
'STUFF HAPPENS HERE
End If
Next indexdstrow
Set dict = Nothing
Is there other way to compare dictionary items with an specified user input?.
Thanks in advance.
#SiddharthRout Kinda, e.g. Im the user and I need to update the record (row) with id 123 so I run the macro, it asks me for the id that I need to update, I input 123 and when I press enter, in the code it should get the id on the source workbook, grab the data and paste it in the destination workbook where the id is 123. Hope this clarifies. –
I have commented the code so you should not have a problem understanding it. Let me know if this is what you want? If not then post your query and I will look at it when I wake up.
Option Explicit
Sub Sample()
Dim srcWorksheet As Worksheet, destinerow As Worksheet
Dim dict As New Dictionary
Dim lRow As Long, i As Long
'~~> Set your source and destination worksheets
Set srcWorksheet = Sheet1
Set destinerow = Sheet2
'~~> Add items to dict from Source worksheet
With srcWorksheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
dict.Add CStr(.Range("A" & i).Value), i
Next i
End With
'~~> Ask user for the criteria
Dim criteria As String
criteria = InputBox("enter id")
'~~> If user presses cancel or item doesn't
'~~> exists in dictionary then exit sub
If criteria = "" Then Exit Sub
If Not dict.Exists(criteria) Then Exit Sub
Dim rngToCopy As Range, aCell As Range
'~~> Find the id in source so we can identify the
'~~> range to copy
With srcWorksheet
Set aCell = .Range("A1:A" & lRow).Find(What:=criteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> I am ssuming the data that you want to copy
'~~> is in Col B. If not then change as applicable
Set rngToCopy = .Range("B" & aCell.Row)
End If
End With
Set aCell = Nothing
'~~> Find the id in destinations so we can identify the
'~~> range where we need to copy
With destinerow
Set aCell = .Columns(1).Find(What:=criteria, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'~~> I am ssuming the data WHERE you want to copy
'~~> is in Col C. If not then change as applicable
rngToCopy.Copy .Range("C" & aCell.Row)
End If
End With
End Sub
I have row data dumped in sheet named "PDFtoEXCEL" and inside this data I have tables that I want to extract into my sheet named "CCE_Lab"
To find the tables I do a search for a keyword that is only available in those tables I am looking for, I search for "Compressibility2"
Then i offset from the active cell which was automatically selected by the search to copy the table and its title from sheet "PDFtoEXCEL" to sheet "CCE_Lab"
After the paste I offset one row below the pasted table
After that is where I need the help, I want the macro to search for the next table with keyword "Compressibility2" and paste it from sheet "PDFtoEXCEL" to sheet "CCE_Lab" one line below the first paste.
I want this search loop to keep going on until all my tables in sheet "PDFtoEXCEL" are copied and pasted to sheet "CCE_Lab"
This is the code I currently have, looking for your help to complete it:
Sub CCE_Tables_Group()
'
' CCE_Tables_Group Macro
' grouping CCE tables from PDF input
'
'
Sheets("PDFtoEXCEL").Select
ActiveCell.Offset(-2546, 0).Range("A1").Select
Cells.Find(What:="Compressibility2", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-2, -4).Range("A1:F25").Select
Selection.Copy
Sheets("CCE_Lab").Select
ActiveCell.Select
ActiveSheet.Paste
ActiveCell.Offset(26, 0).Range("A1").Select
End Sub
If your "tables" aren't Excel tables, then obviously you can't solve this by conveniently looping over ListObjects.
So instead try a Do-Until loop, and loop through all Find results until you're back at your first one (it should loop back to your first result eventually).
Something like:
Option Explicit
Private Sub CopyMatchingTablesToSheet()
Const NUMBER_OF_ROWS_BETWEEN_PASTES As Long = 1
With ThisWorkbook
Dim outputSheet As Worksheet
Set outputSheet = .Worksheets("CCE_Lab")
'outputSheet.Cells.Clear ' Uncomment this if you want to clear the sheet before pasting.
Dim sourceSheet As Worksheet
Set sourceSheet = .Worksheets("PDFtoExcel")
End With
Dim findResult As Range
Set findResult = sourceSheet.Cells.Find(What:="Compressibility2", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If findResult Is Nothing Then
MsgBox ("Could not find a single 'Compressibility2' in worksheet '" & sourceSheet.Name & "'." & vbNewLine & vbNewLine & "Code will stop running now.")
Exit Sub
End If
Dim lastRow As Long
lastRow = outputSheet.Cells(outputSheet.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1 + NUMBER_OF_ROWS_BETWEEN_PASTES
Dim firstAddressFound As String
firstAddressFound = findResult.Address
Dim addressFound As String
Do
With findResult.Offset(-2, -4).Range("A1:F25") 'Magic numbers used in offset.
.Copy
outputSheet.Cells(lastRow, "A").PasteSpecial xlPasteValuesAndNumberFormats ' If you want to paste "everything", then use something like xlPasteAll below
lastRow = lastRow + .Rows.Count + NUMBER_OF_ROWS_BETWEEN_PASTES
End With
Set findResult = sourceSheet.Cells.FindNext(findResult)
addressFound = findResult.Address
DoEvents ' Get rid of this if you want.
Loop Until (firstAddressFound = addressFound) Or (findResult Is Nothing) ' This second condition is likely unnecessary
Application.CutCopyMode = False
End Sub
Maybe something like the below will do what you're after.
In short, we loop through every table on "PDFtoExcel" sheet, check if it contains the sub-string and then handle the copy-paste from there.
Option Explicit
Private Sub CopyMatchingTablesToSheet()
With ThisWorkbook
' Uncomment the line below if you want to clear the sheet before pasting.
' .Worksheets("CCE_LAB").Cells.Clear
Const NUMBER_OF_ROWS_BETWEEN_PASTES As Long = 1
Dim table As ListObject
For Each table In .Worksheets("PDFtoExcel").ListObjects
' table.Range (below) will search the table's body and headers for "Compressibility2"
' If you only want to search the table's body, then change to table.DataBodyRange
Dim findResult As Range
Set findResult = table.Range.Find(What:="Compressibility2", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not (findResult Is Nothing) Then
' Again, if you only to copy-paste the table's body,
' then change below to table.DataBodyRange.Copy
table.Range.Copy
With .Worksheets("CCE_LAB")
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then lastRow = lastRow + 1 + NUMBER_OF_ROWS_BETWEEN_PASTES
' If you want to paste "everything", then use something like xlPasteAll below
' But I think xlPasteAll will create another Excel table on your CCE_Lab sheet
' with some new, unique name -- which can make the document a mess.
' Your call.
.Cells(lastRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
End With
End If
Next table
Application.CutCopyMode = False
End With
End Sub
I'm working on a VBA Macro for a database I have in Excel. I've got one Worksheet that stores information such as names, emails etc. (sadly those are not consistently placed in the same columns across all worksheets, but the email adresses span from "B:F"), this database is split into multiple worksheets. Except all those worksheets, I have also got one other worksheet ("Sheet2" in the code below) that stores all the email addresses that have assigned to my newsletter. (The only information in this sheet are the email addresses in the "A" column).
The VBA I'm working on should loop through all the email adresses that have subscribed to the newsletter ("Sheet2") and check if they're stored in "the database" - in the other sheets as well. If not, then give a warning - write "NOTFOUND" in the cell next to the email.
For some reason, VBA gives me a run-time error "Object doesn't support this property or method" on the row:
With Sheets(sheetIndex).Range("B:F").
Originally I thought that the reason for that is that I have not activated the Sheets, but I'm still getting the error.
The code I came up with so far:
Sub Search_for_emails()
Dim scanstring As String
Dim foundscan As Range
Dim lastRowIndex As Long
Dim ASheet As Worksheet
Set ASheet = Sheets("Sheet2")
lastRowInteger = ASheet.Range("A1", ASheet.Range("A1").End(xlDown)).Rows.Count
For rowNum = 1 To lastRowInteger
scanstring = Sheets("Sheet2").Cells(rowNum, 1).Value
For sheetIndex = 1 To ThisWorkbook.Sheets.Count
Sheets(sheetIndex).Activate
If Sheets(sheetIndex).Name <> "Sheet2" Then
With Sheets(sheetIndex).Range("B:F")
Set foundscan = .Find(What:=scanstring, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If foundscan Is Nothing Then
ASheet.Cells(rowNum, 2).Value = "NOTFOUND"
Else
' ASheet.Cells(rowNum, 2).Value = foundscan.Rows.Count
End If
End If
Next
Next rowNum
End Sub
Some points:
You should avoid Activate - no need for that.
You should always qualify things like
sheet or range, else Excel will use the active workbook /
sheet, and that is not always what you want.
There is a difference between the Sheets and the Worksheets collection. A Chart-sheet, for example, has no cells and therefore no Range.
You are declaring a variable lastRowIndex but uses lastRowInteger. To avoid such errors, always put Option Explicit at the top of your code.
Change your Sub to
Sub Search_for_emails()
Dim scanstring As String
Dim foundscan As Range
Dim lastRowIndex As Long, rowNum As Long
Dim ASheet As Worksheet
Set ASheet = ThisWorkbook.Worksheets("Sheet2")
lastRowIndex = ASheet.Range("A1", ASheet.Range("A1").End(xlDown)).Rows.Count
For rowNum = 1 To lastRowIndex
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sheet2" Then
With ws.Range("B:F")
Set foundscan = .Find(What:=scanstring, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
End With
If foundscan Is Nothing Then
ASheet.Cells(rowNum, 2).Value = "NOTFOUND"
Else
' ASheet.Cells(rowNum, 2).Value = foundscan.Rows.Count
End If
End If
Next
Next rowNum
End Sub