I have wrote a code which paste the borders on Sheet1 used range whenever i make an entry and same for Sheet2. The data is cover by borders automatically.
I have been facing an error (select method of range class failed) if i apply the both codes in sheet1 and Sheet2.
If i use the code for single sheet it works.
Is there an way to merge these both codes OR any way to make it work OR to do this thing in an efficient way.
Any help will be appreciated.
Sheet1
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim lngLstCol As Long, lngLstRow As Long
lngLstRow = Sheet1.UsedRange.Rows.Count
lngLstCol = Sheet1.UsedRange.Columns.Count
For Each rngCell In Range("A2:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Sheet2
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
lngLstRow = Worksheets("Current Stock").UsedRange.Rows.Count
lngLstCol = Worksheets("Current Stock").UsedRange.Columns.Count
For Each rngCell In Range("A2:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
Range(Cells(r, c), Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
End If
Next
Application.ScreenUpdating = True
End Sub
If i use the code for single sheet it works.
This might be because you are not fully qualifying ranges: If you don not qualify Cells and Range it works on the activesheet so you need to pre-qualify wuith the sheet that contains the ranges so target.parent.Cells and target.parent.range might solve your problem
Is there an way to merge these both code
Define a sub which takes a worksheet as a parameter
sub do_the_work(byref ws as worksheet)
Application.ScreenUpdating = False
lngLstRow = Worksheets("Current Stock").UsedRange.Rows.Count
lngLstCol = Worksheets("Current Stock").UsedRange.Columns.Count
For Each rngCell In ws.Range("A2:A" & lngLstRow)
If rngCell.Value > "" Then
r = rngCell.Row
c = rngCell.Column
ws.Range(ws.Cells(r, c), ws.Cells(r, lngLstCol)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
End If
Next
Application.ScreenUpdating = True
end sub
then inside the worksheet.change call
Private Sub Worksheet_Change(ByVal Target As Range)
do_the_work target.parent
End Sub
Improvement removing select
With ws.Range(ws.Cells(r, c), ws.Cells(r, lngLstCol))
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Font
.Name = "Calibri"
.Size = 10
End With
End With
#Modifying Question for better understanding and how do i want the result is.
Wizhi answer almost matched for my question !! But need some more
changes in his answer because which code is not working for me !! And
no need to work based on GCN Date as he answered. The split work
done based on Destination Pincode .
Please help someone help me to Macro Code for Split data into multiple sheet within an excel workbook based on a table format. Below is the explanation of how i have done as per my knowledge and what is my expectation is !!
"Here is the workbooks what i have Done"
Please download the Macro_Folder and Unzip it in you "C" Drive.
Open Macro Workbook and Press Button to run macro.
If it asked for updating formulas as shown in below picture please select "Don't Update" to continue macro.
My Macro workbook view :
I Have done button option to Run the split macro in separate excel workbook.
Where the files Located
When self open and run Macro from Macro Workbook it automatically opens my XD MIS Report and start formatting and split the date into multiple sheets.
View of XD MIS is "Master Data" which is having overall raw data.
Here is the view after self Run Macro fro split Master data.
Code that i Used For Split Data into Multiple Sheet:
Sub Spli_Data()
Dim wb As Workbook
Dim myfilename As String
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
myfilename = "C:\Macro\XD MIS Report.xlsx"
Set wb = Workbooks.Open(myfilename)
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.EntireRow.Hidden = False
Columns("B:F").Select
Range("B2").Activate
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Range("D2").Activate
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Range("H2").Activate
Selection.Delete Shift:=xlToLeft
Columns("K:L").Select
Range("K2").Activate
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Range("D2").Activate
Selection.Cut
Selection.End(xlToRight).Select
Columns("K:K").Select
Range("K2").Activate
Selection.Insert Shift:=xlToRight
Selection.End(xlUp).Select
Range("K1").Select
ActiveCell.FormulaR1C1 = "Remarks"
Columns("J:J").Select
Selection.Copy
Columns("K:K").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("H1").Select
ActiveCell.FormulaR1C1 = "Packing Type"
Range("H1").Select
Selection.End(xlToLeft).Select
Cells.Select
Selection.FormatConditions.Delete
Columns("B:B").Select
Selection.Copy
Columns("A:A").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=COUNTIF(R[-1]C[6]:RC[6],RC[6])"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R1C7:RC[6],RC[6])"
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FillDown
Selection.End(xlUp).Select
Columns("A:A").Select
Range("A2").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A2").Select
Application.CutCopyMode = False
Range("A1:L3100").Select
Range("A2").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection.Font
.Name = "Calibri"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
End With
With Selection.Font
.Name = "Calibri Light"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontMajor
End With
Range("A2").Select
Application.ScreenUpdating = False
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="3", Type:=1)
Set ws = ActiveSheet
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Next
ws.AutoFilterMode = False
ws.Activate
Application.ScreenUpdating = True
End Sub
Result Of Split Data What i have right now:
Destination 1
Destination 2
Now Let's Clear About My Requirement:
I have done macro for format and Split Data into multiple Sheet,But this the not exact format result which i'm looking for.
The split should be done in same method but for result format should be like below formats based on macro code.
The split data should be in Multiple sheets of within an Excel Workbook . Not split to multiple workbooks !!
Write a macro for split Data in this format for all Destination Pincode:
This how i'm expecting final result through macro code
Expected Format of #Destination 1 Sample After Split done
#Destination 1 Sample
This is an examples of what i'm looking for. The same have to done
for all destination which is in Master Data
Hope !! now my question is clear for better understanding and easy to answer.
Updated code:
#Mark Balhoff, Thanks for your valuable input, I always like to learn and get feedback to improve myself :). I have used your input in the code and also extended it a bit.
This code is using dictionary so you need to activate "Microsoft Scripting Runtime"
"Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
User process to split Master Data:
I assume that the user will split this data in the picture:
Pressing the button, it will choose column 7.
(My opinion is that this part with InputBox etc... is unnecessary as you always want to filter by column 7 regardless, so I feel it confused the end user)
Is quite unclear from what "raw data" you start with as new pictures/data have appeared in the updated question. I have assumed that the data that we should split looks like this, as it was stated first
Output of the first unique Destination Pincode:
Output of the second unique Destination Pincode:
Code:
Option Explicit
Sub Split()
Dim lr As Long
Dim lc As Long
Dim ws As Worksheet
Dim ws_new As Worksheet
Dim DestPincode As Range
Dim DestPincodeCol As Long
Dim vcol As Long
Dim vcol_value As String
Dim vcol_name As String
Dim vcol_prompt As String
Dim i As Integer
Dim DestPincode_ws_new As Range
Dim DestPincodeCol_ws_new As Long
Dim DestPincodeRow_ws_new As Long
Application.ScreenUpdating = False
'##### SETTINGS #####
Set ws = ActiveWorkbook.Worksheets("Master_Data") 'Set master data sheet
Set DestPincode = ws.Range(ws.Cells(1, 1), ws.Cells(1, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
'####################
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'Find last column in Master Data
DestPincodeCol = DestPincode.Column 'Get column number for Destination Pincode
lr = ws.Cells(ws.Rows.Count, DestPincodeCol).End(xlUp).Row 'Get last row
'This macro splits data into multiple worksheets based on the variables on a column found in Excel.
'An InputBox asks you which columns you'd like to filter by, and it just creates these worksheets.
'##### Filter based on InputBox #####
vcol = Application.InputBox(prompt:="Which column would you like to filter by?", title:="Filter column", Default:="7", Type:=1)
If vcol <> 7 Then Exit Sub
'##### Get all the uniqe "Destination Pincodes" #####
' You need to activate "Tools" -> "References" -> "Microsoft Scripting Runtime" to make dictionary work
Dim DestPincodeData()
Dim UniqueDestPincodeData As Object
Dim DestPinRow As Long
Set UniqueDestPincodeData = CreateObject("Scripting.Dictionary")
DestPincodeData = Application.Transpose(ws.Range(ws.Cells(1, DestPincodeCol), ws.Cells(ws.Cells(Rows.Count, DestPincodeCol).End(xlUp).Row, DestPincodeCol))) 'Get all the Destination Pincode values
For DestPinRow = 2 To UBound(DestPincodeData, 1) 'Start from row 2 (to skip header) and add unique values to the dictionary
UniqueDestPincodeData(DestPincodeData(DestPinRow)) = 1 'Add value to dictionary
Next
'##### Loop through all the unqie Destination Pincodes and add to seperate workbooks #####
Dim new_wb As Workbook
Set new_wb = Application.Workbooks.Add 'Add new workbook
'Set new_wb = ActiveWorkbook
Dim DestPincodeName As Variant
Dim MyRangeFilter As Range
Set MyRangeFilter = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)) 'Filter range 'Set filter range
For Each DestPincodeName In UniqueDestPincodeData.Keys 'Filter through all the unique names in dictionary "UniqueDestPincodeData"
'Debug.Print "Destination Pincode: " & DestPincodeName 'Print current unique Destination Pincode name
'Filter the data based on "Destination Pincode" and Column from InputBox
With MyRangeFilter
.AutoFilter Field:=DestPincodeCol, Criteria1:=DestPincodeName, Operator:=xlFilterValues 'Filter on Destination Pincode
End With
'##### Create new workbook for the filtered data #####
'To add to new worksheet:
Sheets.Add(After:=Sheets(Sheets.Count)).Name = DestPincodeName
Set ws_new = new_wb.Worksheets(DestPincodeName)
'##### Create template in the new workbook #####
'Building template output, row by row
ws_new.Range("A1:A7").Value = WorksheetFunction.Transpose( _
Array("*******", "TRIP NO", "TRIP DATE/TIME", "TRUCKTYPE (OWN/ATT/ADHOC)", "SEAL #", "SUPERVISOR NAME", "REMARK"))
ws_new.Range("H2:H6").Value = WorksheetFunction.Transpose( _
Array("VEHICLE NO", "VEHICLE CAPACITY", "DRIVER NAME", "DRIVER NO", "VENDOR NAME"))
Dim Top_Area_Cell_Format As Range
Set Top_Area_Cell_Format = ws_new.Range("A1:L1,A7:L7,A2:D2,E2:G2,H2:I2,J2:L2," _
& "A3:D3,E3:G3,H3:I3,J3:L3,A4:D4,E4:G4,H4:I4," _
& "J4:L4,A5:D5,E5:G5,H5:I5,J5:L5,A6:D6,E6:G6,H6:I6,J6:L6")
Application.DisplayAlerts = False
Top_Area_Cell_Format.Merge 'Merge cells
Top_Area_Cell_Format.HorizontalAlignment = xlLeft 'Make title in center
Top_Area_Cell_Format.Borders.LineStyle = xlContinuous 'Add border lines
Top_Area_Cell_Format.Font.Bold = True 'Add Bold text
ws_new.Range("A1:L1").HorizontalAlignment = xlCenter 'Make title in center
Application.DisplayAlerts = True
'##### Paste filtered data from Master_Data sheet #####
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).HorizontalAlignment = xlCenter 'Make text in center
ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc)).SpecialCells(xlCellTypeVisible).EntireRow.Copy 'Copy entire row from filtered data
ws_new.Cells(8, "A").PasteSpecial xlPasteAll 'Paste all values including formats
Set DestPincode_ws_new = ws_new.Range(ws_new.Cells(8, 1), ws_new.Cells(1, ws_new.Cells(8, ws_new.Columns.Count).End(xlToLeft).Column)).Find(What:="Destination Pincode", LookIn:=xlValues, LookAt:=xlWhole) 'Set name to search after, i.e. Destination
DestPincodeCol_ws_new = DestPincode_ws_new.Column
DestPincodeRow_ws_new = ws_new.Cells(ws_new.Rows.Count, DestPincodeCol_ws_new).End(xlUp).Row
'Add total
ws_new.Cells(DestPincodeRow_ws_new + 1, "A").Value = "TOTAL"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Merge 'Merge cells
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).HorizontalAlignment = xlCenter 'Make text in center
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "A"), ws_new.Cells(DestPincodeRow_ws_new + 1, "G")).Font.Bold = True 'Add Bold text
'Add total values
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "I"), ws_new.Cells(DestPincodeRow_ws_new + 1, "I")).Formula = "=SUM(I9:I" & DestPincodeRow_ws_new & ")" 'Add sum for "No. of cartons"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "J"), ws_new.Cells(DestPincodeRow_ws_new + 1, "J")).Formula = "=SUM(J9:J" & DestPincodeRow_ws_new & ")" 'Add sum for "Actual weights"
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Borders.LineStyle = xlContinuous 'Add border lines
ws_new.Range(ws_new.Cells(DestPincodeRow_ws_new + 1, "H"), ws_new.Cells(DestPincodeRow_ws_new + 1, "L")).Font.Bold = True 'Add Bold text
'##### Add sign boxes #####
Dim Bottom_Area_Cell_Text_Rng As String
Dim Bottom_Area_Cell_Format As String
Dim Bottom_Area_Cell_Format_rng As Range
Bottom_Area_Cell_Text_Rng = "B" & DestPincodeRow_ws_new + 2 & ":H" & DestPincodeRow_ws_new + 2
ws_new.Range(Bottom_Area_Cell_Text_Rng).Value = Array("Driver Signature", "", "Incharge Signature", "", "Security Signature", "", "REMARK")
Bottom_Area_Cell_Format = "A" & DestPincodeRow_ws_new + 2 & ":A" & DestPincodeRow_ws_new + 4 & "," _
& "B" & DestPincodeRow_ws_new + 2 & ":C" & DestPincodeRow_ws_new + 4 & "," _
& "D" & DestPincodeRow_ws_new + 2 & ":E" & DestPincodeRow_ws_new + 4 & "," _
& "F" & DestPincodeRow_ws_new + 2 & ":G" & DestPincodeRow_ws_new + 4 & "," _
& "H" & DestPincodeRow_ws_new + 2 & ":L" & DestPincodeRow_ws_new + 4
Set Bottom_Area_Cell_Format_rng = ws_new.Range(Bottom_Area_Cell_Format)
Application.DisplayAlerts = False
Bottom_Area_Cell_Format_rng.Merge 'Merge cells
Bottom_Area_Cell_Format_rng.HorizontalAlignment = xlLeft 'Make title in center
Bottom_Area_Cell_Format_rng.Borders.LineStyle = xlContinuous 'Add border lines
Bottom_Area_Cell_Format_rng.VerticalAlignment = xlTop 'Alignment of text
Bottom_Area_Cell_Format_rng.Font.Bold = True 'Add Bold text
Application.DisplayAlerts = True
'Adjust Column width
ws_new.Columns("A:L").Select
Selection.EntireColumn.AutoFit
Set ws_new = Nothing 'Reset worksheet value
Next
Application.DisplayAlerts = False
new_wb.Worksheets(1).Delete
Application.DisplayAlerts = True
On Error Resume Next
Sheet1.ShowAllData 'remove filter
On Error GoTo 0
ws.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Link to workbook:
https://www.dropbox.com/s/86wlv99y6wylpn8/split%20data.xlsm?dl=0
I'm not sure If I've understand properly, but it looks like you want to split your data depending on the value of PINCODE column.
Besides, your question is too broad right now, you should focus more.
So, as example, I understand you would select all rows containing PINCODE=PUZHAL, and copy all of them into a different workbook.
And you want this for each unique PINCODE.
I made a fake dataset coloring rows, and I split the data into new workbooks. You'll need to adapt this to paste the data into existing workbooks (or new worksheets of same workbook, whatever)
My data is like this:
My code:
Sub TEST()
Application.ScreenUpdating = False
Dim MyDict As Object
Dim i As Long
Dim MyKey As Variant
Dim LR As Long
Dim WB As Workbook
Dim MyRows As Variant
LR = Range("G" & Rows.Count).End(xlUp).Row
Set MyDict = CreateObject("Scripting.Dictionary")
For i = 2 To LR Step 1
If MyDict.Exists(Range("G" & i).Value) = False Then
'we create the PINCODE in Dictionary and assign row number
MyDict.Add Range("G" & i).Value, i
Else
'PINCODE already in Dictionary, we add the new row number
MyDict(Range("G" & i).Value) = MyDict(Range("G" & i).Value) & "|" & i
End If
Next i
'now Dictionary holds all pincodes and all row numbers for each pincode.
'we create a workbook for each PINCODE, but you can adapt this to open a exact workbook depending on PINCODE
'I'm copying the rows starting at row 1, but you can adapt this to your model for sure
For Each MyKey In MyDict.Keys
Set WB = Application.Workbooks.Add
LR = 1 'change this to starting row
MyRows = Split(MyDict(MyKey), "|") 'we create array of rows numbers
For i = LBound(MyRows) To UBound(MyRows) Step 1
'we copy range A:L from that row into destiny workbook
ThisWorkbook.ActiveSheet.Range("A" & MyRows(i) & ":L" & MyRows(i)).Copy WB.ActiveSheet.Range("A" & LR & ":L" & LR)
LR = LR + 1 'we increase LR so next data will be pasted into next row
Next i
Erase MyRows
Set WB = Nothing
DoEvents
Next MyKey
MyDict.RemoveAll
Set MyDict = Nothing
Application.ScreenUpdating = True
End Sub
And this is how i get all my data splitted into different files depending on PINCODE.
I suggest You create a Pivot Table.
By that Pivot table you create a code to extract data on a pivotable base on a list and transfer that to the formatted workbook you created and make a loop until the last Destination Pincode. I also use Excel VBA Form to Trigger this. I can make you one if you post your Excel here.
I've created a macro that transfers the selected value from the dropdown list to the sheet with the same name as the value. I recommend that you review it.
Source : Split data into multiple sheets
I am looking to copy data from a column to a column on another sheet.
Sheet one has a list of ID numbers (starting at F3) next to clock in and out times. There will be anything from 5 - 31 entries of the ID number, before moving to the next employee.
On sheet two is a time sheet with one row per day. The first row of each employee is blank (starting at C8) with the balance of data on that row (name, trade, site etc.) being a reference to this blank cell. There will be anywhere from 29 - 31 rows per employee on sheet two, to allow for all calendar days of the month.
I am trying to search sheet one for the next unique ID, then copy that value to the next available blank cell on sheet two.
The code I have works (sort of) when referencing between sheets and filling in the first value. Selecting the next unique value and then looping till the end of the list is eluding me.
Image of spreadsheets: https://www.dropbox.com/s/vg08uxb9kma2tza/VBA%20Help.jpg?dl=0
Sub TimesheetID()
ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("All Go").Activate
Range("E3").Select
Selection.Copy
Worksheets("Timesheet").Activate
Range("C7").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection.Font
.Name = "Arial"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Worksheets("All GO").Activate
GoAgain:
ThisRow = ThisRow + 1
If ThisRow > Application.Rows.Count Then
Cells(ThisRow - 1, ThisCol).Select
Beep
Exit Sub
End If
If Cells(ThisRow, ThisCol).Value = ThisVal Then
GoTo GoAgain
Else
Cells(ThisRow, ThisCol).Select
End If
ActiveCell.Select
Selection.Copy
Worksheets("Timesheet").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection.Font
.Name = "Arial"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
This example uses two dictionaries and the Dictionary.Exists method to create an array of unique values from the range A1:A50.
Option Explicit
Sub UniqueList()
Dim UniqueDic As Object
Dim AllDic As Object
Dim rng As Range
Dim c As Range
Dim UniqueArray() As Variant
Set UniqueDic = CreateObject("Scripting.Dictionary")
Set AllDic = CreateObject("Scripting.Dictionary")
Set rng = ActiveSheet.Range("$A$1:$A50")
For Each c In rng.Cells
If Not AllDic.Exists(c.Value2)
UniqueDic.Add c.Value2, c.Row
AllDic.Add c.Value2, c.Row
Else
If Not UniqueDic.Exists(c.Value2) Then
UniqueDic.Remove c.Value2
End If
End If
Next
UniqueArray() = Array(UniqueDic.Keys)
End Sub
If a range is traversed and a dictionary, "AllDic", gains a key equal to the cell value when Not AllDic.Exists Cell.Value evaluates to true; then AllDic.Keys will return an array of values unique to "AllDic" but not necessarily unique to the range.
Using two dictionaries, "AllDic" and "UniqueDic", if they both get the same key when Not AllDic.Exists Cell.Value evaluates to true, but when it is false "UniqueDic" will lose a key if Not UniqueDic.Exists Cell.Value is true; then keys from both dictionaries will return arrays with unique values, however, "UniqueDic" will not have any values that repeat in the range.
I managed to work around using this:
Sub TDSFillTest()
Dim BadgeNo As Integer
Dim BlankCount As Integer
Dim LoopCount As Integer
LoopCount = 1
ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
Worksheets("Timesheet").Activate 'Go to Timesheet and count blank cells
BlankCount = Range(("C8"), Cells(Rows.Count, 2).End(xlUp)).Cells.SpecialCells(xlCellTypeBlanks).Count
Worksheets("All Go").Activate 'Starting Point
Range("F3").Copy Worksheets("Timesheet").Range("C8") 'First Value to Timesheet
Worksheets("All Go").Activate ' Return to TDS
Range("F3").Select
Do Until LoopCount > BlankCount
Worksheets("All Go").Activate
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> ActiveCell.Offset(-1, 0).Value Then Exit Do
Loop
ActiveCell.Copy
Worksheets("Timesheet").Activate
ActiveCell.Offset(1, 0).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
LoopCount = LoopCount + 1
Loop
End Sub
I'm going to take yours and run through it in detail so I can learn the more efficient methods. Thanks!
I changed the color and other things of cell M1 in a worksheet. I need to do the same thing in all worksheets of my workbook (the same cell in all the sheets).
There are about 40 sheets so I need to program this task with VBA.
I recorded the procedure but don't know how to write the code to do this in all the worksheets.
The code I recorded:
Sub Macro_1() '' Macro_1 Macro ' Change the look of a cell in all worksheets '
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Try this for starters:
Option Explicit 'always use this, this helps avoiding typing mistakes in code
Sub MyRoutine()
'declaration of variables
Dim colIndex As Long, rowIndex As Long, ws As Worksheet
colIndex = 13 'M column
rowIndex = 1 'first row
'loop through all worksheets
For Each ws In Sheets
ws.Cells(rowIndex, colIndex).Interior.ColorIndex = 1 'put your color here
'do other stuff with the cell, like
'ws.Cells(rowIndex, colIndex).Value = "some value"
Next
End Sub
Loop each sheet of your workbook and apply the color formatting. below is the example code - sets bold property to first cell of every sheet.
For Each sh In ThisWorkbook.Sheets
'Do your format here.
sh.Range("$A$1").Font.Bold = True
Next
You can modify this for you needs:
Option Explicit
Sub allsheets()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Sheets
ws.Cells(1, 1).Value = "TEST"
Next
End Sub